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 /*{{{FILE *my_tmpfile()*/
2087 FILE *
2088 my_tmpfile(void)
2089 {
2090   FILE *fp;
2091   char *cp;
2092
2093   if ((fp = tmpfile())) return fp;
2094
2095   cp = PerlMem_malloc(L_tmpnam+24);
2096   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2097
2098   if (decc_filename_unix_only == 0)
2099     strcpy(cp,"Sys$Scratch:");
2100   else
2101     strcpy(cp,"/tmp/");
2102   tmpnam(cp+strlen(cp));
2103   strcat(cp,".Perltmp");
2104   fp = fopen(cp,"w+","fop=dlt");
2105   PerlMem_free(cp);
2106   return fp;
2107 }
2108 /*}}}*/
2109
2110
2111 #ifndef HOMEGROWN_POSIX_SIGNALS
2112 /*
2113  * The C RTL's sigaction fails to check for invalid signal numbers so we
2114  * help it out a bit.  The docs are correct, but the actual routine doesn't
2115  * do what the docs say it will.
2116  */
2117 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2118 int
2119 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2120                    struct sigaction* oact)
2121 {
2122   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2123         SETERRNO(EINVAL, SS$_INVARG);
2124         return -1;
2125   }
2126   return sigaction(sig, act, oact);
2127 }
2128 /*}}}*/
2129 #endif
2130
2131 #ifdef KILL_BY_SIGPRC
2132 #include <errnodef.h>
2133
2134 /* We implement our own kill() using the undocumented system service
2135    sys$sigprc for one of two reasons:
2136
2137    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2138    target process to do a sys$exit, which usually can't be handled
2139    gracefully...certainly not by Perl and the %SIG{} mechanism.
2140
2141    2.) If the kill() in the CRTL can't be called from a signal
2142    handler without disappearing into the ether, i.e., the signal
2143    it purportedly sends is never trapped. Still true as of VMS 7.3.
2144
2145    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2146    in the target process rather than calling sys$exit.
2147
2148    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2149    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2150    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2151    with condition codes C$_SIG0+nsig*8, catching the exception on the
2152    target process and resignaling with appropriate arguments.
2153
2154    But we don't have that VMS 7.0+ exception handler, so if you
2155    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2156
2157    Also note that SIGTERM is listed in the docs as being "unimplemented",
2158    yet always seems to be signaled with a VMS condition code of 4 (and
2159    correctly handled for that code).  So we hardwire it in.
2160
2161    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2162    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2163    than signalling with an unrecognized (and unhandled by CRTL) code.
2164 */
2165
2166 #define _MY_SIG_MAX 28
2167
2168 static unsigned int
2169 Perl_sig_to_vmscondition_int(int sig)
2170 {
2171     static unsigned int sig_code[_MY_SIG_MAX+1] =
2172     {
2173         0,                  /*  0 ZERO     */
2174         SS$_HANGUP,         /*  1 SIGHUP   */
2175         SS$_CONTROLC,       /*  2 SIGINT   */
2176         SS$_CONTROLY,       /*  3 SIGQUIT  */
2177         SS$_RADRMOD,        /*  4 SIGILL   */
2178         SS$_BREAK,          /*  5 SIGTRAP  */
2179         SS$_OPCCUS,         /*  6 SIGABRT  */
2180         SS$_COMPAT,         /*  7 SIGEMT   */
2181 #ifdef __VAX
2182         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2183 #else
2184         SS$_HPARITH,        /*  8 SIGFPE AXP */
2185 #endif
2186         SS$_ABORT,          /*  9 SIGKILL  */
2187         SS$_ACCVIO,         /* 10 SIGBUS   */
2188         SS$_ACCVIO,         /* 11 SIGSEGV  */
2189         SS$_BADPARAM,       /* 12 SIGSYS   */
2190         SS$_NOMBX,          /* 13 SIGPIPE  */
2191         SS$_ASTFLT,         /* 14 SIGALRM  */
2192         4,                  /* 15 SIGTERM  */
2193         0,                  /* 16 SIGUSR1  */
2194         0,                  /* 17 SIGUSR2  */
2195         0,                  /* 18 */
2196         0,                  /* 19 */
2197         0,                  /* 20 SIGCHLD  */
2198         0,                  /* 21 SIGCONT  */
2199         0,                  /* 22 SIGSTOP  */
2200         0,                  /* 23 SIGTSTP  */
2201         0,                  /* 24 SIGTTIN  */
2202         0,                  /* 25 SIGTTOU  */
2203         0,                  /* 26 */
2204         0,                  /* 27 */
2205         0                   /* 28 SIGWINCH  */
2206     };
2207
2208 #if __VMS_VER >= 60200000
2209     static int initted = 0;
2210     if (!initted) {
2211         initted = 1;
2212         sig_code[16] = C$_SIGUSR1;
2213         sig_code[17] = C$_SIGUSR2;
2214 #if __CRTL_VER >= 70000000
2215         sig_code[20] = C$_SIGCHLD;
2216 #endif
2217 #if __CRTL_VER >= 70300000
2218         sig_code[28] = C$_SIGWINCH;
2219 #endif
2220     }
2221 #endif
2222
2223     if (sig < _SIG_MIN) return 0;
2224     if (sig > _MY_SIG_MAX) return 0;
2225     return sig_code[sig];
2226 }
2227
2228 unsigned int
2229 Perl_sig_to_vmscondition(int sig)
2230 {
2231 #ifdef SS$_DEBUG
2232     if (vms_debug_on_exception != 0)
2233         lib$signal(SS$_DEBUG);
2234 #endif
2235     return Perl_sig_to_vmscondition_int(sig);
2236 }
2237
2238
2239 int
2240 Perl_my_kill(int pid, int sig)
2241 {
2242     dTHX;
2243     int iss;
2244     unsigned int code;
2245     int sys$sigprc(unsigned int *pidadr,
2246                      struct dsc$descriptor_s *prcname,
2247                      unsigned int code);
2248
2249      /* sig 0 means validate the PID */
2250     /*------------------------------*/
2251     if (sig == 0) {
2252         const unsigned long int jpicode = JPI$_PID;
2253         pid_t ret_pid;
2254         int status;
2255         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2256         if ($VMS_STATUS_SUCCESS(status))
2257            return 0;
2258         switch (status) {
2259         case SS$_NOSUCHNODE:
2260         case SS$_UNREACHABLE:
2261         case SS$_NONEXPR:
2262            errno = ESRCH;
2263            break;
2264         case SS$_NOPRIV:
2265            errno = EPERM;
2266            break;
2267         default:
2268            errno = EVMSERR;
2269         }
2270         vaxc$errno=status;
2271         return -1;
2272     }
2273
2274     code = Perl_sig_to_vmscondition_int(sig);
2275
2276     if (!code) {
2277         SETERRNO(EINVAL, SS$_BADPARAM);
2278         return -1;
2279     }
2280
2281     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2282      * signals are to be sent to multiple processes.
2283      *  pid = 0 - all processes in group except ones that the system exempts
2284      *  pid = -1 - all processes except ones that the system exempts
2285      *  pid = -n - all processes in group (abs(n)) except ...
2286      * For now, just report as not supported.
2287      */
2288
2289     if (pid <= 0) {
2290         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2291         return -1;
2292     }
2293
2294     iss = sys$sigprc((unsigned int *)&pid,0,code);
2295     if (iss&1) return 0;
2296
2297     switch (iss) {
2298       case SS$_NOPRIV:
2299         set_errno(EPERM);  break;
2300       case SS$_NONEXPR:
2301       case SS$_NOSUCHNODE:
2302       case SS$_UNREACHABLE:
2303         set_errno(ESRCH);  break;
2304       case SS$_INSFMEM:
2305         set_errno(ENOMEM); break;
2306       default:
2307         _ckvmssts(iss);
2308         set_errno(EVMSERR);
2309     }
2310     set_vaxc_errno(iss);
2311
2312     return -1;
2313 }
2314 #endif
2315
2316 /* Routine to convert a VMS status code to a UNIX status code.
2317 ** More tricky than it appears because of conflicting conventions with
2318 ** existing code.
2319 **
2320 ** VMS status codes are a bit mask, with the least significant bit set for
2321 ** success.
2322 **
2323 ** Special UNIX status of EVMSERR indicates that no translation is currently
2324 ** available, and programs should check the VMS status code.
2325 **
2326 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2327 ** decoding.
2328 */
2329
2330 #ifndef C_FACILITY_NO
2331 #define C_FACILITY_NO 0x350000
2332 #endif
2333 #ifndef DCL_IVVERB
2334 #define DCL_IVVERB 0x38090
2335 #endif
2336
2337 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2338 {
2339 int facility;
2340 int fac_sp;
2341 int msg_no;
2342 int msg_status;
2343 int unix_status;
2344
2345   /* Assume the best or the worst */
2346   if (vms_status & STS$M_SUCCESS)
2347     unix_status = 0;
2348   else
2349     unix_status = EVMSERR;
2350
2351   msg_status = vms_status & ~STS$M_CONTROL;
2352
2353   facility = vms_status & STS$M_FAC_NO;
2354   fac_sp = vms_status & STS$M_FAC_SP;
2355   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2356
2357   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2358     switch(msg_no) {
2359     case SS$_NORMAL:
2360         unix_status = 0;
2361         break;
2362     case SS$_ACCVIO:
2363         unix_status = EFAULT;
2364         break;
2365     case SS$_DEVOFFLINE:
2366         unix_status = EBUSY;
2367         break;
2368     case SS$_CLEARED:
2369         unix_status = ENOTCONN;
2370         break;
2371     case SS$_IVCHAN:
2372     case SS$_IVLOGNAM:
2373     case SS$_BADPARAM:
2374     case SS$_IVLOGTAB:
2375     case SS$_NOLOGNAM:
2376     case SS$_NOLOGTAB:
2377     case SS$_INVFILFOROP:
2378     case SS$_INVARG:
2379     case SS$_NOSUCHID:
2380     case SS$_IVIDENT:
2381         unix_status = EINVAL;
2382         break;
2383     case SS$_UNSUPPORTED:
2384         unix_status = ENOTSUP;
2385         break;
2386     case SS$_FILACCERR:
2387     case SS$_NOGRPPRV:
2388     case SS$_NOSYSPRV:
2389         unix_status = EACCES;
2390         break;
2391     case SS$_DEVICEFULL:
2392         unix_status = ENOSPC;
2393         break;
2394     case SS$_NOSUCHDEV:
2395         unix_status = ENODEV;
2396         break;
2397     case SS$_NOSUCHFILE:
2398     case SS$_NOSUCHOBJECT:
2399         unix_status = ENOENT;
2400         break;
2401     case SS$_ABORT:                                 /* Fatal case */
2402     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2403     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2404         unix_status = EINTR;
2405         break;
2406     case SS$_BUFFEROVF:
2407         unix_status = E2BIG;
2408         break;
2409     case SS$_INSFMEM:
2410         unix_status = ENOMEM;
2411         break;
2412     case SS$_NOPRIV:
2413         unix_status = EPERM;
2414         break;
2415     case SS$_NOSUCHNODE:
2416     case SS$_UNREACHABLE:
2417         unix_status = ESRCH;
2418         break;
2419     case SS$_NONEXPR:
2420         unix_status = ECHILD;
2421         break;
2422     default:
2423         if ((facility == 0) && (msg_no < 8)) {
2424           /* These are not real VMS status codes so assume that they are
2425           ** already UNIX status codes
2426           */
2427           unix_status = msg_no;
2428           break;
2429         }
2430     }
2431   }
2432   else {
2433     /* Translate a POSIX exit code to a UNIX exit code */
2434     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2435         unix_status = (msg_no & 0x07F8) >> 3;
2436     }
2437     else {
2438
2439          /* Documented traditional behavior for handling VMS child exits */
2440         /*--------------------------------------------------------------*/
2441         if (child_flag != 0) {
2442
2443              /* Success / Informational return 0 */
2444             /*----------------------------------*/
2445             if (msg_no & STS$K_SUCCESS)
2446                 return 0;
2447
2448              /* Warning returns 1 */
2449             /*-------------------*/
2450             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2451                 return 1;
2452
2453              /* Everything else pass through the severity bits */
2454             /*------------------------------------------------*/
2455             return (msg_no & STS$M_SEVERITY);
2456         }
2457
2458          /* Normal VMS status to ERRNO mapping attempt */
2459         /*--------------------------------------------*/
2460         switch(msg_status) {
2461         /* case RMS$_EOF: */ /* End of File */
2462         case RMS$_FNF:  /* File Not Found */
2463         case RMS$_DNF:  /* Dir Not Found */
2464                 unix_status = ENOENT;
2465                 break;
2466         case RMS$_RNF:  /* Record Not Found */
2467                 unix_status = ESRCH;
2468                 break;
2469         case RMS$_DIR:
2470                 unix_status = ENOTDIR;
2471                 break;
2472         case RMS$_DEV:
2473                 unix_status = ENODEV;
2474                 break;
2475         case RMS$_IFI:
2476         case RMS$_FAC:
2477         case RMS$_ISI:
2478                 unix_status = EBADF;
2479                 break;
2480         case RMS$_FEX:
2481                 unix_status = EEXIST;
2482                 break;
2483         case RMS$_SYN:
2484         case RMS$_FNM:
2485         case LIB$_INVSTRDES:
2486         case LIB$_INVARG:
2487         case LIB$_NOSUCHSYM:
2488         case LIB$_INVSYMNAM:
2489         case DCL_IVVERB:
2490                 unix_status = EINVAL;
2491                 break;
2492         case CLI$_BUFOVF:
2493         case RMS$_RTB:
2494         case CLI$_TKNOVF:
2495         case CLI$_RSLOVF:
2496                 unix_status = E2BIG;
2497                 break;
2498         case RMS$_PRV:  /* No privilege */
2499         case RMS$_ACC:  /* ACP file access failed */
2500         case RMS$_WLK:  /* Device write locked */
2501                 unix_status = EACCES;
2502                 break;
2503         /* case RMS$_NMF: */  /* No more files */
2504         }
2505     }
2506   }
2507
2508   return unix_status;
2509 }
2510
2511 /* Try to guess at what VMS error status should go with a UNIX errno
2512  * value.  This is hard to do as there could be many possible VMS
2513  * error statuses that caused the errno value to be set.
2514  */
2515
2516 int Perl_unix_status_to_vms(int unix_status)
2517 {
2518 int test_unix_status;
2519
2520      /* Trivial cases first */
2521     /*---------------------*/
2522     if (unix_status == EVMSERR)
2523         return vaxc$errno;
2524
2525      /* Is vaxc$errno sane? */
2526     /*---------------------*/
2527     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2528     if (test_unix_status == unix_status)
2529         return vaxc$errno;
2530
2531      /* If way out of range, must be VMS code already */
2532     /*-----------------------------------------------*/
2533     if (unix_status > EVMSERR)
2534         return unix_status;
2535
2536      /* If out of range, punt */
2537     /*-----------------------*/
2538     if (unix_status > __ERRNO_MAX)
2539         return SS$_ABORT;
2540
2541
2542      /* Ok, now we have to do it the hard way. */
2543     /*----------------------------------------*/
2544     switch(unix_status) {
2545     case 0:     return SS$_NORMAL;
2546     case EPERM: return SS$_NOPRIV;
2547     case ENOENT: return SS$_NOSUCHOBJECT;
2548     case ESRCH: return SS$_UNREACHABLE;
2549     case EINTR: return SS$_ABORT;
2550     /* case EIO: */
2551     /* case ENXIO:  */
2552     case E2BIG: return SS$_BUFFEROVF;
2553     /* case ENOEXEC */
2554     case EBADF: return RMS$_IFI;
2555     case ECHILD: return SS$_NONEXPR;
2556     /* case EAGAIN */
2557     case ENOMEM: return SS$_INSFMEM;
2558     case EACCES: return SS$_FILACCERR;
2559     case EFAULT: return SS$_ACCVIO;
2560     /* case ENOTBLK */
2561     case EBUSY: return SS$_DEVOFFLINE;
2562     case EEXIST: return RMS$_FEX;
2563     /* case EXDEV */
2564     case ENODEV: return SS$_NOSUCHDEV;
2565     case ENOTDIR: return RMS$_DIR;
2566     /* case EISDIR */
2567     case EINVAL: return SS$_INVARG;
2568     /* case ENFILE */
2569     /* case EMFILE */
2570     /* case ENOTTY */
2571     /* case ETXTBSY */
2572     /* case EFBIG */
2573     case ENOSPC: return SS$_DEVICEFULL;
2574     case ESPIPE: return LIB$_INVARG;
2575     /* case EROFS: */
2576     /* case EMLINK: */
2577     /* case EPIPE: */
2578     /* case EDOM */
2579     case ERANGE: return LIB$_INVARG;
2580     /* case EWOULDBLOCK */
2581     /* case EINPROGRESS */
2582     /* case EALREADY */
2583     /* case ENOTSOCK */
2584     /* case EDESTADDRREQ */
2585     /* case EMSGSIZE */
2586     /* case EPROTOTYPE */
2587     /* case ENOPROTOOPT */
2588     /* case EPROTONOSUPPORT */
2589     /* case ESOCKTNOSUPPORT */
2590     /* case EOPNOTSUPP */
2591     /* case EPFNOSUPPORT */
2592     /* case EAFNOSUPPORT */
2593     /* case EADDRINUSE */
2594     /* case EADDRNOTAVAIL */
2595     /* case ENETDOWN */
2596     /* case ENETUNREACH */
2597     /* case ENETRESET */
2598     /* case ECONNABORTED */
2599     /* case ECONNRESET */
2600     /* case ENOBUFS */
2601     /* case EISCONN */
2602     case ENOTCONN: return SS$_CLEARED;
2603     /* case ESHUTDOWN */
2604     /* case ETOOMANYREFS */
2605     /* case ETIMEDOUT */
2606     /* case ECONNREFUSED */
2607     /* case ELOOP */
2608     /* case ENAMETOOLONG */
2609     /* case EHOSTDOWN */
2610     /* case EHOSTUNREACH */
2611     /* case ENOTEMPTY */
2612     /* case EPROCLIM */
2613     /* case EUSERS  */
2614     /* case EDQUOT  */
2615     /* case ENOMSG  */
2616     /* case EIDRM */
2617     /* case EALIGN */
2618     /* case ESTALE */
2619     /* case EREMOTE */
2620     /* case ENOLCK */
2621     /* case ENOSYS */
2622     /* case EFTYPE */
2623     /* case ECANCELED */
2624     /* case EFAIL */
2625     /* case EINPROG */
2626     case ENOTSUP:
2627         return SS$_UNSUPPORTED;
2628     /* case EDEADLK */
2629     /* case ENWAIT */
2630     /* case EILSEQ */
2631     /* case EBADCAT */
2632     /* case EBADMSG */
2633     /* case EABANDONED */
2634     default:
2635         return SS$_ABORT; /* punt */
2636     }
2637
2638   return SS$_ABORT; /* Should not get here */
2639 }
2640
2641
2642 /* default piping mailbox size */
2643 #define PERL_BUFSIZ        512
2644
2645
2646 static void
2647 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2648 {
2649   unsigned long int mbxbufsiz;
2650   static unsigned long int syssize = 0;
2651   unsigned long int dviitm = DVI$_DEVNAM;
2652   char csize[LNM$C_NAMLENGTH+1];
2653   int sts;
2654
2655   if (!syssize) {
2656     unsigned long syiitm = SYI$_MAXBUF;
2657     /*
2658      * Get the SYSGEN parameter MAXBUF
2659      *
2660      * If the logical 'PERL_MBX_SIZE' is defined
2661      * use the value of the logical instead of PERL_BUFSIZ, but
2662      * keep the size between 128 and MAXBUF.
2663      *
2664      */
2665     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2666   }
2667
2668   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2669       mbxbufsiz = atoi(csize);
2670   } else {
2671       mbxbufsiz = PERL_BUFSIZ;
2672   }
2673   if (mbxbufsiz < 128) mbxbufsiz = 128;
2674   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2675
2676   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2677
2678   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2679   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2680
2681 }  /* end of create_mbx() */
2682
2683
2684 /*{{{  my_popen and my_pclose*/
2685
2686 typedef struct _iosb           IOSB;
2687 typedef struct _iosb*         pIOSB;
2688 typedef struct _pipe           Pipe;
2689 typedef struct _pipe*         pPipe;
2690 typedef struct pipe_details    Info;
2691 typedef struct pipe_details*  pInfo;
2692 typedef struct _srqp            RQE;
2693 typedef struct _srqp*          pRQE;
2694 typedef struct _tochildbuf      CBuf;
2695 typedef struct _tochildbuf*    pCBuf;
2696
2697 struct _iosb {
2698     unsigned short status;
2699     unsigned short count;
2700     unsigned long  dvispec;
2701 };
2702
2703 #pragma member_alignment save
2704 #pragma nomember_alignment quadword
2705 struct _srqp {          /* VMS self-relative queue entry */
2706     unsigned long qptr[2];
2707 };
2708 #pragma member_alignment restore
2709 static RQE  RQE_ZERO = {0,0};
2710
2711 struct _tochildbuf {
2712     RQE             q;
2713     int             eof;
2714     unsigned short  size;
2715     char            *buf;
2716 };
2717
2718 struct _pipe {
2719     RQE            free;
2720     RQE            wait;
2721     int            fd_out;
2722     unsigned short chan_in;
2723     unsigned short chan_out;
2724     char          *buf;
2725     unsigned int   bufsize;
2726     IOSB           iosb;
2727     IOSB           iosb2;
2728     int           *pipe_done;
2729     int            retry;
2730     int            type;
2731     int            shut_on_empty;
2732     int            need_wake;
2733     pPipe         *home;
2734     pInfo          info;
2735     pCBuf          curr;
2736     pCBuf          curr2;
2737 #if defined(PERL_IMPLICIT_CONTEXT)
2738     void            *thx;           /* Either a thread or an interpreter */
2739                                     /* pointer, depending on how we're built */
2740 #endif
2741 };
2742
2743
2744 struct pipe_details
2745 {
2746     pInfo           next;
2747     PerlIO *fp;  /* file pointer to pipe mailbox */
2748     int useFILE; /* using stdio, not perlio */
2749     int pid;   /* PID of subprocess */
2750     int mode;  /* == 'r' if pipe open for reading */
2751     int done;  /* subprocess has completed */
2752     int waiting; /* waiting for completion/closure */
2753     int             closing;        /* my_pclose is closing this pipe */
2754     unsigned long   completion;     /* termination status of subprocess */
2755     pPipe           in;             /* pipe in to sub */
2756     pPipe           out;            /* pipe out of sub */
2757     pPipe           err;            /* pipe of sub's sys$error */
2758     int             in_done;        /* true when in pipe finished */
2759     int             out_done;
2760     int             err_done;
2761     unsigned short  xchan;          /* channel to debug xterm */
2762     unsigned short  xchan_valid;    /* channel is assigned */
2763 };
2764
2765 struct exit_control_block
2766 {
2767     struct exit_control_block *flink;
2768     unsigned long int   (*exit_routine)();
2769     unsigned long int arg_count;
2770     unsigned long int *status_address;
2771     unsigned long int exit_status;
2772 };
2773
2774 typedef struct _closed_pipes    Xpipe;
2775 typedef struct _closed_pipes*  pXpipe;
2776
2777 struct _closed_pipes {
2778     int             pid;            /* PID of subprocess */
2779     unsigned long   completion;     /* termination status of subprocess */
2780 };
2781 #define NKEEPCLOSED 50
2782 static Xpipe closed_list[NKEEPCLOSED];
2783 static int   closed_index = 0;
2784 static int   closed_num = 0;
2785
2786 #define RETRY_DELAY     "0 ::0.20"
2787 #define MAX_RETRY              50
2788
2789 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2790 static unsigned long mypid;
2791 static unsigned long delaytime[2];
2792
2793 static pInfo open_pipes = NULL;
2794 static $DESCRIPTOR(nl_desc, "NL:");
2795
2796 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2797
2798
2799
2800 static unsigned long int
2801 pipe_exit_routine(pTHX)
2802 {
2803     pInfo info;
2804     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2805     int sts, did_stuff, need_eof, j;
2806
2807    /*
2808     * Flush any pending i/o, but since we are in process run-down, be
2809     * careful about referencing PerlIO structures that may already have
2810     * been deallocated.  We may not even have an interpreter anymore.
2811     */
2812     info = open_pipes;
2813     while (info) {
2814         if (info->fp) {
2815            if (!info->useFILE
2816 #if defined(USE_ITHREADS)
2817              && my_perl
2818 #endif
2819              && PL_perlio_fd_refcnt)
2820                PerlIO_flush(info->fp);
2821            else
2822                fflush((FILE *)info->fp);
2823         }
2824         info = info->next;
2825     }
2826
2827     /*
2828      next we try sending an EOF...ignore if doesn't work, make sure we
2829      don't hang
2830     */
2831     did_stuff = 0;
2832     info = open_pipes;
2833
2834     while (info) {
2835       int need_eof;
2836       _ckvmssts_noperl(sys$setast(0));
2837       if (info->in && !info->in->shut_on_empty) {
2838         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2839                           0, 0, 0, 0, 0, 0));
2840         info->waiting = 1;
2841         did_stuff = 1;
2842       }
2843       _ckvmssts_noperl(sys$setast(1));
2844       info = info->next;
2845     }
2846
2847     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2848
2849     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2850         int nwait = 0;
2851
2852         info = open_pipes;
2853         while (info) {
2854           _ckvmssts_noperl(sys$setast(0));
2855           if (info->waiting && info->done)
2856                 info->waiting = 0;
2857           nwait += info->waiting;
2858           _ckvmssts_noperl(sys$setast(1));
2859           info = info->next;
2860         }
2861         if (!nwait) break;
2862         sleep(1);
2863     }
2864
2865     did_stuff = 0;
2866     info = open_pipes;
2867     while (info) {
2868       _ckvmssts_noperl(sys$setast(0));
2869       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2870         sts = sys$forcex(&info->pid,0,&abort);
2871         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2872         did_stuff = 1;
2873       }
2874       _ckvmssts_noperl(sys$setast(1));
2875       info = info->next;
2876     }
2877
2878     /* again, wait for effect */
2879
2880     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2881         int nwait = 0;
2882
2883         info = open_pipes;
2884         while (info) {
2885           _ckvmssts_noperl(sys$setast(0));
2886           if (info->waiting && info->done)
2887                 info->waiting = 0;
2888           nwait += info->waiting;
2889           _ckvmssts_noperl(sys$setast(1));
2890           info = info->next;
2891         }
2892         if (!nwait) break;
2893         sleep(1);
2894     }
2895
2896     info = open_pipes;
2897     while (info) {
2898       _ckvmssts_noperl(sys$setast(0));
2899       if (!info->done) {  /* We tried to be nice . . . */
2900         sts = sys$delprc(&info->pid,0);
2901         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2902         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2903       }
2904       _ckvmssts_noperl(sys$setast(1));
2905       info = info->next;
2906     }
2907
2908     while(open_pipes) {
2909       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2910       else if (!(sts & 1)) retsts = sts;
2911     }
2912     return retsts;
2913 }
2914
2915 static struct exit_control_block pipe_exitblock =
2916        {(struct exit_control_block *) 0,
2917         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2918
2919 static void pipe_mbxtofd_ast(pPipe p);
2920 static void pipe_tochild1_ast(pPipe p);
2921 static void pipe_tochild2_ast(pPipe p);
2922
2923 static void
2924 popen_completion_ast(pInfo info)
2925 {
2926   pInfo i = open_pipes;
2927   int iss;
2928   int sts;
2929   pXpipe x;
2930
2931   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2932   closed_list[closed_index].pid = info->pid;
2933   closed_list[closed_index].completion = info->completion;
2934   closed_index++;
2935   if (closed_index == NKEEPCLOSED)
2936     closed_index = 0;
2937   closed_num++;
2938
2939   while (i) {
2940     if (i == info) break;
2941     i = i->next;
2942   }
2943   if (!i) return;       /* unlinked, probably freed too */
2944
2945   info->done = TRUE;
2946
2947 /*
2948     Writing to subprocess ...
2949             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2950
2951             chan_out may be waiting for "done" flag, or hung waiting
2952             for i/o completion to child...cancel the i/o.  This will
2953             put it into "snarf mode" (done but no EOF yet) that discards
2954             input.
2955
2956     Output from subprocess (stdout, stderr) needs to be flushed and
2957     shut down.   We try sending an EOF, but if the mbx is full the pipe
2958     routine should still catch the "shut_on_empty" flag, telling it to
2959     use immediate-style reads so that "mbx empty" -> EOF.
2960
2961
2962 */
2963   if (info->in && !info->in_done) {               /* only for mode=w */
2964         if (info->in->shut_on_empty && info->in->need_wake) {
2965             info->in->need_wake = FALSE;
2966             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2967         } else {
2968             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2969         }
2970   }
2971
2972   if (info->out && !info->out_done) {             /* were we also piping output? */
2973       info->out->shut_on_empty = TRUE;
2974       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2975       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2976       _ckvmssts_noperl(iss);
2977   }
2978
2979   if (info->err && !info->err_done) {        /* we were piping stderr */
2980         info->err->shut_on_empty = TRUE;
2981         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2982         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2983         _ckvmssts_noperl(iss);
2984   }
2985   _ckvmssts_noperl(sys$setef(pipe_ef));
2986
2987 }
2988
2989 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2990 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2991
2992 /*
2993     we actually differ from vmstrnenv since we use this to
2994     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2995     are pointing to the same thing
2996 */
2997
2998 static unsigned short
2999 popen_translate(pTHX_ char *logical, char *result)
3000 {
3001     int iss;
3002     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3003     $DESCRIPTOR(d_log,"");
3004     struct _il3 {
3005         unsigned short length;
3006         unsigned short code;
3007         char *         buffer_addr;
3008         unsigned short *retlenaddr;
3009     } itmlst[2];
3010     unsigned short l, ifi;
3011
3012     d_log.dsc$a_pointer = logical;
3013     d_log.dsc$w_length  = strlen(logical);
3014
3015     itmlst[0].code = LNM$_STRING;
3016     itmlst[0].length = 255;
3017     itmlst[0].buffer_addr = result;
3018     itmlst[0].retlenaddr = &l;
3019
3020     itmlst[1].code = 0;
3021     itmlst[1].length = 0;
3022     itmlst[1].buffer_addr = 0;
3023     itmlst[1].retlenaddr = 0;
3024
3025     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3026     if (iss == SS$_NOLOGNAM) {
3027         iss = SS$_NORMAL;
3028         l = 0;
3029     }
3030     if (!(iss&1)) lib$signal(iss);
3031     result[l] = '\0';
3032 /*
3033     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3034     strip it off and return the ifi, if any
3035 */
3036     ifi  = 0;
3037     if (result[0] == 0x1b && result[1] == 0x00) {
3038         memmove(&ifi,result+2,2);
3039         strcpy(result,result+4);
3040     }
3041     return ifi;     /* this is the RMS internal file id */
3042 }
3043
3044 static void pipe_infromchild_ast(pPipe p);
3045
3046 /*
3047     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3048     inside an AST routine without worrying about reentrancy and which Perl
3049     memory allocator is being used.
3050
3051     We read data and queue up the buffers, then spit them out one at a
3052     time to the output mailbox when the output mailbox is ready for one.
3053
3054 */
3055 #define INITIAL_TOCHILDQUEUE  2
3056
3057 static pPipe
3058 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3059 {
3060     pPipe p;
3061     pCBuf b;
3062     char mbx1[64], mbx2[64];
3063     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3064                                       DSC$K_CLASS_S, mbx1},
3065                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3066                                       DSC$K_CLASS_S, mbx2};
3067     unsigned int dviitm = DVI$_DEVBUFSIZ;
3068     int j, n;
3069
3070     n = sizeof(Pipe);
3071     _ckvmssts(lib$get_vm(&n, &p));
3072
3073     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3074     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3075     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3076
3077     p->buf           = 0;
3078     p->shut_on_empty = FALSE;
3079     p->need_wake     = FALSE;
3080     p->type          = 0;
3081     p->retry         = 0;
3082     p->iosb.status   = SS$_NORMAL;
3083     p->iosb2.status  = SS$_NORMAL;
3084     p->free          = RQE_ZERO;
3085     p->wait          = RQE_ZERO;
3086     p->curr          = 0;
3087     p->curr2         = 0;
3088     p->info          = 0;
3089 #ifdef PERL_IMPLICIT_CONTEXT
3090     p->thx           = aTHX;
3091 #endif
3092
3093     n = sizeof(CBuf) + p->bufsize;
3094
3095     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3096         _ckvmssts(lib$get_vm(&n, &b));
3097         b->buf = (char *) b + sizeof(CBuf);
3098         _ckvmssts(lib$insqhi(b, &p->free));
3099     }
3100
3101     pipe_tochild2_ast(p);
3102     pipe_tochild1_ast(p);
3103     strcpy(wmbx, mbx1);
3104     strcpy(rmbx, mbx2);
3105     return p;
3106 }
3107
3108 /*  reads the MBX Perl is writing, and queues */
3109
3110 static void
3111 pipe_tochild1_ast(pPipe p)
3112 {
3113     pCBuf b = p->curr;
3114     int iss = p->iosb.status;
3115     int eof = (iss == SS$_ENDOFFILE);
3116     int sts;
3117 #ifdef PERL_IMPLICIT_CONTEXT
3118     pTHX = p->thx;
3119 #endif
3120
3121     if (p->retry) {
3122         if (eof) {
3123             p->shut_on_empty = TRUE;
3124             b->eof     = TRUE;
3125             _ckvmssts(sys$dassgn(p->chan_in));
3126         } else  {
3127             _ckvmssts(iss);
3128         }
3129
3130         b->eof  = eof;
3131         b->size = p->iosb.count;
3132         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3133         if (p->need_wake) {
3134             p->need_wake = FALSE;
3135             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3136         }
3137     } else {
3138         p->retry = 1;   /* initial call */
3139     }
3140
3141     if (eof) {                  /* flush the free queue, return when done */
3142         int n = sizeof(CBuf) + p->bufsize;
3143         while (1) {
3144             iss = lib$remqti(&p->free, &b);
3145             if (iss == LIB$_QUEWASEMP) return;
3146             _ckvmssts(iss);
3147             _ckvmssts(lib$free_vm(&n, &b));
3148         }
3149     }
3150
3151     iss = lib$remqti(&p->free, &b);
3152     if (iss == LIB$_QUEWASEMP) {
3153         int n = sizeof(CBuf) + p->bufsize;
3154         _ckvmssts(lib$get_vm(&n, &b));
3155         b->buf = (char *) b + sizeof(CBuf);
3156     } else {
3157        _ckvmssts(iss);
3158     }
3159
3160     p->curr = b;
3161     iss = sys$qio(0,p->chan_in,
3162              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3163              &p->iosb,
3164              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3165     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3166     _ckvmssts(iss);
3167 }
3168
3169
3170 /* writes queued buffers to output, waits for each to complete before
3171    doing the next */
3172
3173 static void
3174 pipe_tochild2_ast(pPipe p)
3175 {
3176     pCBuf b = p->curr2;
3177     int iss = p->iosb2.status;
3178     int n = sizeof(CBuf) + p->bufsize;
3179     int done = (p->info && p->info->done) ||
3180               iss == SS$_CANCEL || iss == SS$_ABORT;
3181 #if defined(PERL_IMPLICIT_CONTEXT)
3182     pTHX = p->thx;
3183 #endif
3184
3185     do {
3186         if (p->type) {         /* type=1 has old buffer, dispose */
3187             if (p->shut_on_empty) {
3188                 _ckvmssts(lib$free_vm(&n, &b));
3189             } else {
3190                 _ckvmssts(lib$insqhi(b, &p->free));
3191             }
3192             p->type = 0;
3193         }
3194
3195         iss = lib$remqti(&p->wait, &b);
3196         if (iss == LIB$_QUEWASEMP) {
3197             if (p->shut_on_empty) {
3198                 if (done) {
3199                     _ckvmssts(sys$dassgn(p->chan_out));
3200                     *p->pipe_done = TRUE;
3201                     _ckvmssts(sys$setef(pipe_ef));
3202                 } else {
3203                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3204                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3205                 }
3206                 return;
3207             }
3208             p->need_wake = TRUE;
3209             return;
3210         }
3211         _ckvmssts(iss);
3212         p->type = 1;
3213     } while (done);
3214
3215
3216     p->curr2 = b;
3217     if (b->eof) {
3218         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3219             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3220     } else {
3221         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3222             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3223     }
3224
3225     return;
3226
3227 }
3228
3229
3230 static pPipe
3231 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3232 {
3233     pPipe p;
3234     char mbx1[64], mbx2[64];
3235     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3236                                       DSC$K_CLASS_S, mbx1},
3237                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3238                                       DSC$K_CLASS_S, mbx2};
3239     unsigned int dviitm = DVI$_DEVBUFSIZ;
3240
3241     int n = sizeof(Pipe);
3242     _ckvmssts(lib$get_vm(&n, &p));
3243     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3244     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3245
3246     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3247     n = p->bufsize * sizeof(char);
3248     _ckvmssts(lib$get_vm(&n, &p->buf));
3249     p->shut_on_empty = FALSE;
3250     p->info   = 0;
3251     p->type   = 0;
3252     p->iosb.status = SS$_NORMAL;
3253 #if defined(PERL_IMPLICIT_CONTEXT)
3254     p->thx = aTHX;
3255 #endif
3256     pipe_infromchild_ast(p);
3257
3258     strcpy(wmbx, mbx1);
3259     strcpy(rmbx, mbx2);
3260     return p;
3261 }
3262
3263 static void
3264 pipe_infromchild_ast(pPipe p)
3265 {
3266     int iss = p->iosb.status;
3267     int eof = (iss == SS$_ENDOFFILE);
3268     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3269     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3270 #if defined(PERL_IMPLICIT_CONTEXT)
3271     pTHX = p->thx;
3272 #endif
3273
3274     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3275         _ckvmssts(sys$dassgn(p->chan_out));
3276         p->chan_out = 0;
3277     }
3278
3279     /* read completed:
3280             input shutdown if EOF from self (done or shut_on_empty)
3281             output shutdown if closing flag set (my_pclose)
3282             send data/eof from child or eof from self
3283             otherwise, re-read (snarf of data from child)
3284     */
3285
3286     if (p->type == 1) {
3287         p->type = 0;
3288         if (myeof && p->chan_in) {                  /* input shutdown */
3289             _ckvmssts(sys$dassgn(p->chan_in));
3290             p->chan_in = 0;
3291         }
3292
3293         if (p->chan_out) {
3294             if (myeof || kideof) {      /* pass EOF to parent */
3295                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3296                               pipe_infromchild_ast, p,
3297                               0, 0, 0, 0, 0, 0));
3298                 return;
3299             } else if (eof) {       /* eat EOF --- fall through to read*/
3300
3301             } else {                /* transmit data */
3302                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3303                               pipe_infromchild_ast,p,
3304                               p->buf, p->iosb.count, 0, 0, 0, 0));
3305                 return;
3306             }
3307         }
3308     }
3309
3310     /*  everything shut? flag as done */
3311
3312     if (!p->chan_in && !p->chan_out) {
3313         *p->pipe_done = TRUE;
3314         _ckvmssts(sys$setef(pipe_ef));
3315         return;
3316     }
3317
3318     /* write completed (or read, if snarfing from child)
3319             if still have input active,
3320                queue read...immediate mode if shut_on_empty so we get EOF if empty
3321             otherwise,
3322                check if Perl reading, generate EOFs as needed
3323     */
3324
3325     if (p->type == 0) {
3326         p->type = 1;
3327         if (p->chan_in) {
3328             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3329                           pipe_infromchild_ast,p,
3330                           p->buf, p->bufsize, 0, 0, 0, 0);
3331             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3332             _ckvmssts(iss);
3333         } else {           /* send EOFs for extra reads */
3334             p->iosb.status = SS$_ENDOFFILE;
3335             p->iosb.dvispec = 0;
3336             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3337                       0, 0, 0,
3338                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3339         }
3340     }
3341 }
3342
3343 static pPipe
3344 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3345 {
3346     pPipe p;
3347     char mbx[64];
3348     unsigned long dviitm = DVI$_DEVBUFSIZ;
3349     struct stat s;
3350     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3351                                       DSC$K_CLASS_S, mbx};
3352     int n = sizeof(Pipe);
3353
3354     /* things like terminals and mbx's don't need this filter */
3355     if (fd && fstat(fd,&s) == 0) {
3356         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3357         char device[65];
3358         unsigned short dev_len;
3359         struct dsc$descriptor_s d_dev;
3360         char * cptr;
3361         struct item_list_3 items[3];
3362         int status;
3363         unsigned short dvi_iosb[4];
3364
3365         cptr = getname(fd, out, 1);
3366         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3367         d_dev.dsc$a_pointer = out;
3368         d_dev.dsc$w_length = strlen(out);
3369         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3370         d_dev.dsc$b_class = DSC$K_CLASS_S;
3371
3372         items[0].len = 4;
3373         items[0].code = DVI$_DEVCHAR;
3374         items[0].bufadr = &devchar;
3375         items[0].retadr = NULL;
3376         items[1].len = 64;
3377         items[1].code = DVI$_FULLDEVNAM;
3378         items[1].bufadr = device;
3379         items[1].retadr = &dev_len;
3380         items[2].len = 0;
3381         items[2].code = 0;
3382
3383         status = sys$getdviw
3384                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3385         _ckvmssts(status);
3386         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3387             device[dev_len] = 0;
3388
3389             if (!(devchar & DEV$M_DIR)) {
3390                 strcpy(out, device);
3391                 return 0;
3392             }
3393         }
3394     }
3395
3396     _ckvmssts(lib$get_vm(&n, &p));
3397     p->fd_out = dup(fd);
3398     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3399     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3400     n = (p->bufsize+1) * sizeof(char);
3401     _ckvmssts(lib$get_vm(&n, &p->buf));
3402     p->shut_on_empty = FALSE;
3403     p->retry = 0;
3404     p->info  = 0;
3405     strcpy(out, mbx);
3406
3407     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3408                   pipe_mbxtofd_ast, p,
3409                   p->buf, p->bufsize, 0, 0, 0, 0));
3410
3411     return p;
3412 }
3413
3414 static void
3415 pipe_mbxtofd_ast(pPipe p)
3416 {
3417     int iss = p->iosb.status;
3418     int done = p->info->done;
3419     int iss2;
3420     int eof = (iss == SS$_ENDOFFILE);
3421     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3422     int err = !(iss&1) && !eof;
3423 #if defined(PERL_IMPLICIT_CONTEXT)
3424     pTHX = p->thx;
3425 #endif
3426
3427     if (done && myeof) {               /* end piping */
3428         close(p->fd_out);
3429         sys$dassgn(p->chan_in);
3430         *p->pipe_done = TRUE;
3431         _ckvmssts(sys$setef(pipe_ef));
3432         return;
3433     }
3434
3435     if (!err && !eof) {             /* good data to send to file */
3436         p->buf[p->iosb.count] = '\n';
3437         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3438         if (iss2 < 0) {
3439             p->retry++;
3440             if (p->retry < MAX_RETRY) {
3441                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3442                 return;
3443             }
3444         }
3445         p->retry = 0;
3446     } else if (err) {
3447         _ckvmssts(iss);
3448     }
3449
3450
3451     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3452           pipe_mbxtofd_ast, p,
3453           p->buf, p->bufsize, 0, 0, 0, 0);
3454     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3455     _ckvmssts(iss);
3456 }
3457
3458
3459 typedef struct _pipeloc     PLOC;
3460 typedef struct _pipeloc*   pPLOC;
3461
3462 struct _pipeloc {
3463     pPLOC   next;
3464     char    dir[NAM$C_MAXRSS+1];
3465 };
3466 static pPLOC  head_PLOC = 0;
3467
3468 void
3469 free_pipelocs(pTHX_ void *head)
3470 {
3471     pPLOC p, pnext;
3472     pPLOC *pHead = (pPLOC *)head;
3473
3474     p = *pHead;
3475     while (p) {
3476         pnext = p->next;
3477         PerlMem_free(p);
3478         p = pnext;
3479     }
3480     *pHead = 0;
3481 }
3482
3483 static void
3484 store_pipelocs(pTHX)
3485 {
3486     int    i;
3487     pPLOC  p;
3488     AV    *av = 0;
3489     SV    *dirsv;
3490     GV    *gv;
3491     char  *dir, *x;
3492     char  *unixdir;
3493     char  temp[NAM$C_MAXRSS+1];
3494     STRLEN n_a;
3495
3496     if (head_PLOC)
3497         free_pipelocs(aTHX_ &head_PLOC);
3498
3499 /*  the . directory from @INC comes last */
3500
3501     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3502     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3503     p->next = head_PLOC;
3504     head_PLOC = p;
3505     strcpy(p->dir,"./");
3506
3507 /*  get the directory from $^X */
3508
3509     unixdir = PerlMem_malloc(VMS_MAXRSS);
3510     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3511
3512 #ifdef PERL_IMPLICIT_CONTEXT
3513     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3514 #else
3515     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3516 #endif
3517         strcpy(temp, PL_origargv[0]);
3518         x = strrchr(temp,']');
3519         if (x == NULL) {
3520         x = strrchr(temp,'>');
3521           if (x == NULL) {
3522             /* It could be a UNIX path */
3523             x = strrchr(temp,'/');
3524           }
3525         }
3526         if (x)
3527           x[1] = '\0';
3528         else {
3529           /* Got a bare name, so use default directory */
3530           temp[0] = '.';
3531           temp[1] = '\0';
3532         }
3533
3534         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3535             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3536             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3537             p->next = head_PLOC;
3538             head_PLOC = p;
3539             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3540             p->dir[NAM$C_MAXRSS] = '\0';
3541         }
3542     }
3543
3544 /*  reverse order of @INC entries, skip "." since entered above */
3545
3546 #ifdef PERL_IMPLICIT_CONTEXT
3547     if (aTHX)
3548 #endif
3549     if (PL_incgv) av = GvAVn(PL_incgv);
3550
3551     for (i = 0; av && i <= AvFILL(av); i++) {
3552         dirsv = *av_fetch(av,i,TRUE);
3553
3554         if (SvROK(dirsv)) continue;
3555         dir = SvPVx(dirsv,n_a);
3556         if (strcmp(dir,".") == 0) continue;
3557         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3558             continue;
3559
3560         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3561         p->next = head_PLOC;
3562         head_PLOC = p;
3563         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3564         p->dir[NAM$C_MAXRSS] = '\0';
3565     }
3566
3567 /* most likely spot (ARCHLIB) put first in the list */
3568
3569 #ifdef ARCHLIB_EXP
3570     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3571         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3572         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3573         p->next = head_PLOC;
3574         head_PLOC = p;
3575         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3576         p->dir[NAM$C_MAXRSS] = '\0';
3577     }
3578 #endif
3579     PerlMem_free(unixdir);
3580 }
3581
3582 static I32
3583 Perl_cando_by_name_int
3584    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3585 #if !defined(PERL_IMPLICIT_CONTEXT)
3586 #define cando_by_name_int               Perl_cando_by_name_int
3587 #else
3588 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3589 #endif
3590
3591 static char *
3592 find_vmspipe(pTHX)
3593 {
3594     static int   vmspipe_file_status = 0;
3595     static char  vmspipe_file[NAM$C_MAXRSS+1];
3596
3597     /* already found? Check and use ... need read+execute permission */
3598
3599     if (vmspipe_file_status == 1) {
3600         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3601          && cando_by_name_int
3602            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3603             return vmspipe_file;
3604         }
3605         vmspipe_file_status = 0;
3606     }
3607
3608     /* scan through stored @INC, $^X */
3609
3610     if (vmspipe_file_status == 0) {
3611         char file[NAM$C_MAXRSS+1];
3612         pPLOC  p = head_PLOC;
3613
3614         while (p) {
3615             char * exp_res;
3616             int dirlen;
3617             strcpy(file, p->dir);
3618             dirlen = strlen(file);
3619             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3620             file[NAM$C_MAXRSS] = '\0';
3621             p = p->next;
3622
3623             exp_res = do_rmsexpand
3624                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3625             if (!exp_res) continue;
3626
3627             if (cando_by_name_int
3628                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3629              && cando_by_name_int
3630                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3631                 vmspipe_file_status = 1;
3632                 return vmspipe_file;
3633             }
3634         }
3635         vmspipe_file_status = -1;   /* failed, use tempfiles */
3636     }
3637
3638     return 0;
3639 }
3640
3641 static FILE *
3642 vmspipe_tempfile(pTHX)
3643 {
3644     char file[NAM$C_MAXRSS+1];
3645     FILE *fp;
3646     static int index = 0;
3647     Stat_t s0, s1;
3648     int cmp_result;
3649
3650     /* create a tempfile */
3651
3652     /* we can't go from   W, shr=get to  R, shr=get without
3653        an intermediate vulnerable state, so don't bother trying...
3654
3655        and lib$spawn doesn't shr=put, so have to close the write
3656
3657        So... match up the creation date/time and the FID to
3658        make sure we're dealing with the same file
3659
3660     */
3661
3662     index++;
3663     if (!decc_filename_unix_only) {
3664       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3665       fp = fopen(file,"w");
3666       if (!fp) {
3667         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3668         fp = fopen(file,"w");
3669         if (!fp) {
3670             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3671             fp = fopen(file,"w");
3672         }
3673       }
3674      }
3675      else {
3676       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3677       fp = fopen(file,"w");
3678       if (!fp) {
3679         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3680         fp = fopen(file,"w");
3681         if (!fp) {
3682           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3683           fp = fopen(file,"w");
3684         }
3685       }
3686     }
3687     if (!fp) return 0;  /* we're hosed */
3688
3689     fprintf(fp,"$! 'f$verify(0)'\n");
3690     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3691     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3692     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3693     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3694     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3695     fprintf(fp,"$ perl_del    = \"delete\"\n");
3696     fprintf(fp,"$ pif         = \"if\"\n");
3697     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3698     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3699     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3700     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3701     fprintf(fp,"$!  --- build command line to get max possible length\n");
3702     fprintf(fp,"$c=perl_popen_cmd0\n");
3703     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3704     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3705     fprintf(fp,"$x=perl_popen_cmd3\n");
3706     fprintf(fp,"$c=c+x\n");
3707     fprintf(fp,"$ perl_on\n");
3708     fprintf(fp,"$ 'c'\n");
3709     fprintf(fp,"$ perl_status = $STATUS\n");
3710     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3711     fprintf(fp,"$ perl_exit 'perl_status'\n");
3712     fsync(fileno(fp));
3713
3714     fgetname(fp, file, 1);
3715     fstat(fileno(fp), (struct stat *)&s0);
3716     fclose(fp);
3717
3718     if (decc_filename_unix_only)
3719         do_tounixspec(file, file, 0, NULL);
3720     fp = fopen(file,"r","shr=get");
3721     if (!fp) return 0;
3722     fstat(fileno(fp), (struct stat *)&s1);
3723
3724     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3725     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3726         fclose(fp);
3727         return 0;
3728     }
3729
3730     return fp;
3731 }
3732
3733
3734 static int vms_is_syscommand_xterm(void)
3735 {
3736     const static struct dsc$descriptor_s syscommand_dsc =
3737       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3738
3739     const static struct dsc$descriptor_s decwdisplay_dsc =
3740       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3741
3742     struct item_list_3 items[2];
3743     unsigned short dvi_iosb[4];
3744     unsigned long devchar;
3745     unsigned long devclass;
3746     int status;
3747
3748     /* Very simple check to guess if sys$command is a decterm? */
3749     /* First see if the DECW$DISPLAY: device exists */
3750     items[0].len = 4;
3751     items[0].code = DVI$_DEVCHAR;
3752     items[0].bufadr = &devchar;
3753     items[0].retadr = NULL;
3754     items[1].len = 0;
3755     items[1].code = 0;
3756
3757     status = sys$getdviw
3758         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3759
3760     if ($VMS_STATUS_SUCCESS(status)) {
3761         status = dvi_iosb[0];
3762     }
3763
3764     if (!$VMS_STATUS_SUCCESS(status)) {
3765         SETERRNO(EVMSERR, status);
3766         return -1;
3767     }
3768
3769     /* If it does, then for now assume that we are on a workstation */
3770     /* Now verify that SYS$COMMAND is a terminal */
3771     /* for creating the debugger DECTerm */
3772
3773     items[0].len = 4;
3774     items[0].code = DVI$_DEVCLASS;
3775     items[0].bufadr = &devclass;
3776     items[0].retadr = NULL;
3777     items[1].len = 0;
3778     items[1].code = 0;
3779
3780     status = sys$getdviw
3781         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3782
3783     if ($VMS_STATUS_SUCCESS(status)) {
3784         status = dvi_iosb[0];
3785     }
3786
3787     if (!$VMS_STATUS_SUCCESS(status)) {
3788         SETERRNO(EVMSERR, status);
3789         return -1;
3790     }
3791     else {
3792         if (devclass == DC$_TERM) {
3793             return 0;
3794         }
3795     }
3796     return -1;
3797 }
3798
3799 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3800 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3801 {
3802     int status;
3803     int ret_stat;
3804     char * ret_char;
3805     char device_name[65];
3806     unsigned short device_name_len;
3807     struct dsc$descriptor_s customization_dsc;
3808     struct dsc$descriptor_s device_name_dsc;
3809     const char * cptr;
3810     char * tptr;
3811     char customization[200];
3812     char title[40];
3813     pInfo info = NULL;
3814     char mbx1[64];
3815     unsigned short p_chan;
3816     int n;
3817     unsigned short iosb[4];
3818     struct item_list_3 items[2];
3819     const char * cust_str =
3820         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3821     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3822                                           DSC$K_CLASS_S, mbx1};
3823
3824      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3825     /*---------------------------------------*/
3826     VAXC$ESTABLISH((__vms_handler)LIB$SIG_TO_RET);
3827
3828
3829     /* Make sure that this is from the Perl debugger */
3830     ret_char = strstr(cmd," xterm ");
3831     if (ret_char == NULL)
3832         return NULL;
3833     cptr = ret_char + 7;
3834     ret_char = strstr(cmd,"tty");
3835     if (ret_char == NULL)
3836         return NULL;
3837     ret_char = strstr(cmd,"sleep");
3838     if (ret_char == NULL)
3839         return NULL;
3840
3841     if (decw_term_port == 0) {
3842         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3843         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3844         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3845
3846         status = LIB$FIND_IMAGE_SYMBOL
3847                                (&filename1_dsc,
3848                                 &decw_term_port_dsc,
3849                                 (void *)&decw_term_port,
3850                                 NULL,
3851                                 0);
3852
3853         /* Try again with the other image name */
3854         if (!$VMS_STATUS_SUCCESS(status)) {
3855
3856             status = LIB$FIND_IMAGE_SYMBOL
3857                                (&filename2_dsc,
3858                                 &decw_term_port_dsc,
3859                                 (void *)&decw_term_port,
3860                                 NULL,
3861                                 0);
3862
3863         }
3864
3865     }
3866
3867
3868     /* No decw$term_port, give it up */
3869     if (!$VMS_STATUS_SUCCESS(status))
3870         return NULL;
3871
3872     /* Are we on a workstation? */
3873     /* to do: capture the rows / columns and pass their properties */
3874     ret_stat = vms_is_syscommand_xterm();
3875     if (ret_stat < 0)
3876         return NULL;
3877
3878     /* Make the title: */
3879     ret_char = strstr(cptr,"-title");
3880     if (ret_char != NULL) {
3881         while ((*cptr != 0) && (*cptr != '\"')) {
3882             cptr++;
3883         }
3884         if (*cptr == '\"')
3885             cptr++;
3886         n = 0;
3887         while ((*cptr != 0) && (*cptr != '\"')) {
3888             title[n] = *cptr;
3889             n++;
3890             if (n == 39) {
3891                 title[39] == 0;
3892                 break;
3893             }
3894             cptr++;
3895         }
3896         title[n] = 0;
3897     }
3898     else {
3899             /* Default title */
3900             strcpy(title,"Perl Debug DECTerm");
3901     }
3902     sprintf(customization, cust_str, title);
3903
3904     customization_dsc.dsc$a_pointer = customization;
3905     customization_dsc.dsc$w_length = strlen(customization);
3906     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3907     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3908
3909     device_name_dsc.dsc$a_pointer = device_name;
3910     device_name_dsc.dsc$w_length = sizeof device_name -1;
3911     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3912     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3913
3914     device_name_len = 0;
3915
3916     /* Try to create the window */
3917      status = (*decw_term_port)
3918        (NULL,
3919         NULL,
3920         &customization_dsc,
3921         &device_name_dsc,
3922         &device_name_len,
3923         NULL,
3924         NULL,
3925         NULL);
3926     if (!$VMS_STATUS_SUCCESS(status)) {
3927         SETERRNO(EVMSERR, status);
3928         return NULL;
3929     }
3930
3931     device_name[device_name_len] = '\0';
3932
3933     /* Need to set this up to look like a pipe for cleanup */
3934     n = sizeof(Info);
3935     status = lib$get_vm(&n, &info);
3936     if (!$VMS_STATUS_SUCCESS(status)) {
3937         SETERRNO(ENOMEM, status);
3938         return NULL;
3939     }
3940
3941     info->mode = *mode;
3942     info->done = FALSE;
3943     info->completion = 0;
3944     info->closing    = FALSE;
3945     info->in         = 0;
3946     info->out        = 0;
3947     info->err        = 0;
3948     info->fp         = Nullfp;
3949     info->useFILE    = 0;
3950     info->waiting    = 0;
3951     info->in_done    = TRUE;
3952     info->out_done   = TRUE;
3953     info->err_done   = TRUE;
3954
3955     /* Assign a channel on this so that it will persist, and not login */
3956     /* We stash this channel in the info structure for reference. */
3957     /* The created xterm self destructs when the last channel is removed */
3958     /* and it appears that perl5db.pl (perl debugger) does this routinely */
3959     /* So leave this assigned. */
3960     device_name_dsc.dsc$w_length = device_name_len;
3961     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
3962     if (!$VMS_STATUS_SUCCESS(status)) {
3963         SETERRNO(EVMSERR, status);
3964         return NULL;
3965     }
3966     info->xchan_valid = 1;
3967
3968     /* Now create a mailbox to be read by the application */
3969
3970     create_mbx(aTHX_ &p_chan, &d_mbx1);
3971
3972     /* write the name of the created terminal to the mailbox */
3973     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
3974             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
3975
3976     if (!$VMS_STATUS_SUCCESS(status)) {
3977         SETERRNO(EVMSERR, status);
3978         return NULL;
3979     }
3980
3981     info->fp  = PerlIO_open(mbx1, mode);
3982
3983     /* Done with this channel */
3984     sys$dassgn(p_chan);
3985
3986     /* If any errors, then clean up */
3987     if (!info->fp) {
3988         n = sizeof(Info);
3989         _ckvmssts(lib$free_vm(&n, &info));
3990         return NULL;
3991         }
3992
3993     /* All done */
3994     return info->fp;
3995 }
3996
3997 static PerlIO *
3998 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3999 {
4000     static int handler_set_up = FALSE;
4001     unsigned long int sts, flags = CLI$M_NOWAIT;
4002     /* The use of a GLOBAL table (as was done previously) rendered
4003      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4004      * environment.  Hence we've switched to LOCAL symbol table.
4005      */
4006     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4007     int j, wait = 0, n;
4008     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4009     char *in, *out, *err, mbx[512];
4010     FILE *tpipe = 0;
4011     char tfilebuf[NAM$C_MAXRSS+1];
4012     pInfo info = NULL;
4013     char cmd_sym_name[20];
4014     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4015                                       DSC$K_CLASS_S, symbol};
4016     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4017                                       DSC$K_CLASS_S, 0};
4018     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4019                                       DSC$K_CLASS_S, cmd_sym_name};
4020     struct dsc$descriptor_s *vmscmd;
4021     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4022     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4023     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4024
4025     /* Check here for Xterm create request.  This means looking for
4026      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4027      *  is possible to create an xterm.
4028      */
4029     if (*in_mode == 'r') {
4030         PerlIO * xterm_fd;
4031
4032         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4033         if (xterm_fd != Nullfp)
4034             return xterm_fd;
4035     }
4036
4037     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4038
4039     /* once-per-program initialization...
4040        note that the SETAST calls and the dual test of pipe_ef
4041        makes sure that only the FIRST thread through here does
4042        the initialization...all other threads wait until it's
4043        done.
4044
4045        Yeah, uglier than a pthread call, it's got all the stuff inline
4046        rather than in a separate routine.
4047     */
4048
4049     if (!pipe_ef) {
4050         _ckvmssts(sys$setast(0));
4051         if (!pipe_ef) {
4052             unsigned long int pidcode = JPI$_PID;
4053             $DESCRIPTOR(d_delay, RETRY_DELAY);
4054             _ckvmssts(lib$get_ef(&pipe_ef));
4055             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4056             _ckvmssts(sys$bintim(&d_delay, delaytime));
4057         }
4058         if (!handler_set_up) {
4059           _ckvmssts(sys$dclexh(&pipe_exitblock));
4060           handler_set_up = TRUE;
4061         }
4062         _ckvmssts(sys$setast(1));
4063     }
4064
4065     /* see if we can find a VMSPIPE.COM */
4066
4067     tfilebuf[0] = '@';
4068     vmspipe = find_vmspipe(aTHX);
4069     if (vmspipe) {
4070         strcpy(tfilebuf+1,vmspipe);
4071     } else {        /* uh, oh...we're in tempfile hell */
4072         tpipe = vmspipe_tempfile(aTHX);
4073         if (!tpipe) {       /* a fish popular in Boston */
4074             if (ckWARN(WARN_PIPE)) {
4075                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4076             }
4077         return Nullfp;
4078         }
4079         fgetname(tpipe,tfilebuf+1,1);
4080     }
4081     vmspipedsc.dsc$a_pointer = tfilebuf;
4082     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4083
4084     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4085     if (!(sts & 1)) {
4086       switch (sts) {
4087         case RMS$_FNF:  case RMS$_DNF:
4088           set_errno(ENOENT); break;
4089         case RMS$_DIR:
4090           set_errno(ENOTDIR); break;
4091         case RMS$_DEV:
4092           set_errno(ENODEV); break;
4093         case RMS$_PRV:
4094           set_errno(EACCES); break;
4095         case RMS$_SYN:
4096           set_errno(EINVAL); break;
4097         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4098           set_errno(E2BIG); break;
4099         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4100           _ckvmssts(sts); /* fall through */
4101         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4102           set_errno(EVMSERR);
4103       }
4104       set_vaxc_errno(sts);
4105       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4106         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4107       }
4108       *psts = sts;
4109       return Nullfp;
4110     }
4111     n = sizeof(Info);
4112     _ckvmssts(lib$get_vm(&n, &info));
4113
4114     strcpy(mode,in_mode);
4115     info->mode = *mode;
4116     info->done = FALSE;
4117     info->completion = 0;
4118     info->closing    = FALSE;
4119     info->in         = 0;
4120     info->out        = 0;
4121     info->err        = 0;
4122     info->fp         = Nullfp;
4123     info->useFILE    = 0;
4124     info->waiting    = 0;
4125     info->in_done    = TRUE;
4126     info->out_done   = TRUE;
4127     info->err_done   = TRUE;
4128     info->xchan      = 0;
4129     info->xchan_valid = 0;
4130
4131     in = PerlMem_malloc(VMS_MAXRSS);
4132     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4133     out = PerlMem_malloc(VMS_MAXRSS);
4134     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4135     err = PerlMem_malloc(VMS_MAXRSS);
4136     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4137
4138     in[0] = out[0] = err[0] = '\0';
4139
4140     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4141         info->useFILE = 1;
4142         strcpy(p,p+1);
4143     }
4144     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4145         wait = 1;
4146         strcpy(p,p+1);
4147     }
4148
4149     if (*mode == 'r') {             /* piping from subroutine */
4150
4151         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4152         if (info->out) {
4153             info->out->pipe_done = &info->out_done;
4154             info->out_done = FALSE;
4155             info->out->info = info;
4156         }
4157         if (!info->useFILE) {
4158             info->fp  = PerlIO_open(mbx, mode);
4159         } else {
4160             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4161             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4162         }
4163
4164         if (!info->fp && info->out) {
4165             sys$cancel(info->out->chan_out);
4166
4167             while (!info->out_done) {
4168                 int done;
4169                 _ckvmssts(sys$setast(0));
4170                 done = info->out_done;
4171                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4172                 _ckvmssts(sys$setast(1));
4173                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4174             }
4175
4176             if (info->out->buf) {
4177                 n = info->out->bufsize * sizeof(char);
4178                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4179             }
4180             n = sizeof(Pipe);
4181             _ckvmssts(lib$free_vm(&n, &info->out));
4182             n = sizeof(Info);
4183             _ckvmssts(lib$free_vm(&n, &info));
4184             *psts = RMS$_FNF;
4185             return Nullfp;
4186         }
4187
4188         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4189         if (info->err) {
4190             info->err->pipe_done = &info->err_done;
4191             info->err_done = FALSE;
4192             info->err->info = info;
4193         }
4194
4195     } else if (*mode == 'w') {      /* piping to subroutine */
4196
4197         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4198         if (info->out) {
4199             info->out->pipe_done = &info->out_done;
4200             info->out_done = FALSE;
4201             info->out->info = info;
4202         }
4203
4204         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4205         if (info->err) {
4206             info->err->pipe_done = &info->err_done;
4207             info->err_done = FALSE;
4208             info->err->info = info;
4209         }
4210
4211         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4212         if (!info->useFILE) {
4213             info->fp  = PerlIO_open(mbx, mode);
4214         } else {
4215             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4216             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4217         }
4218
4219         if (info->in) {
4220             info->in->pipe_done = &info->in_done;
4221             info->in_done = FALSE;
4222             info->in->info = info;
4223         }
4224
4225         /* error cleanup */
4226         if (!info->fp && info->in) {
4227             info->done = TRUE;
4228             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4229                               0, 0, 0, 0, 0, 0, 0, 0));
4230
4231             while (!info->in_done) {
4232                 int done;
4233                 _ckvmssts(sys$setast(0));
4234                 done = info->in_done;
4235                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4236                 _ckvmssts(sys$setast(1));
4237                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4238             }
4239
4240             if (info->in->buf) {
4241                 n = info->in->bufsize * sizeof(char);
4242                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4243             }
4244             n = sizeof(Pipe);
4245             _ckvmssts(lib$free_vm(&n, &info->in));
4246             n = sizeof(Info);
4247             _ckvmssts(lib$free_vm(&n, &info));
4248             *psts = RMS$_FNF;
4249             return Nullfp;
4250         }
4251
4252
4253     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4254         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4255         if (info->out) {
4256             info->out->pipe_done = &info->out_done;
4257             info->out_done = FALSE;
4258             info->out->info = info;
4259         }
4260
4261         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4262         if (info->err) {
4263             info->err->pipe_done = &info->err_done;
4264             info->err_done = FALSE;
4265             info->err->info = info;
4266         }
4267     }
4268
4269     symbol[MAX_DCL_SYMBOL] = '\0';
4270
4271     strncpy(symbol, in, MAX_DCL_SYMBOL);
4272     d_symbol.dsc$w_length = strlen(symbol);
4273     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4274
4275     strncpy(symbol, err, MAX_DCL_SYMBOL);
4276     d_symbol.dsc$w_length = strlen(symbol);
4277     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4278
4279     strncpy(symbol, out, MAX_DCL_SYMBOL);
4280     d_symbol.dsc$w_length = strlen(symbol);
4281     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4282
4283     /* Done with the names for the pipes */
4284     PerlMem_free(err);
4285     PerlMem_free(out);
4286     PerlMem_free(in);
4287
4288     p = vmscmd->dsc$a_pointer;
4289     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4290     if (*p == '$') p++;                         /* remove leading $ */
4291     while (*p == ' ' || *p == '\t') p++;
4292
4293     for (j = 0; j < 4; j++) {
4294         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4295         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4296
4297     strncpy(symbol, p, MAX_DCL_SYMBOL);
4298     d_symbol.dsc$w_length = strlen(symbol);
4299     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4300
4301         if (strlen(p) > MAX_DCL_SYMBOL) {
4302             p += MAX_DCL_SYMBOL;
4303         } else {
4304             p += strlen(p);
4305         }
4306     }
4307     _ckvmssts(sys$setast(0));
4308     info->next=open_pipes;  /* prepend to list */
4309     open_pipes=info;
4310     _ckvmssts(sys$setast(1));
4311     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4312      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4313      * have SYS$COMMAND if we need it.
4314      */
4315     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4316                       0, &info->pid, &info->completion,
4317                       0, popen_completion_ast,info,0,0,0));
4318
4319     /* if we were using a tempfile, close it now */
4320
4321     if (tpipe) fclose(tpipe);
4322
4323     /* once the subprocess is spawned, it has copied the symbols and
4324        we can get rid of ours */
4325
4326     for (j = 0; j < 4; j++) {
4327         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4328         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4329     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4330     }
4331     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4332     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4333     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4334     vms_execfree(vmscmd);
4335
4336 #ifdef PERL_IMPLICIT_CONTEXT
4337     if (aTHX)
4338 #endif
4339     PL_forkprocess = info->pid;
4340
4341     if (wait) {
4342          int done = 0;
4343          while (!done) {
4344              _ckvmssts(sys$setast(0));
4345              done = info->done;
4346              if (!done) _ckvmssts(sys$clref(pipe_ef));
4347              _ckvmssts(sys$setast(1));
4348              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4349          }
4350         *psts = info->completion;
4351 /* Caller thinks it is open and tries to close it. */
4352 /* This causes some problems, as it changes the error status */
4353 /*        my_pclose(info->fp); */
4354     } else {
4355         *psts = SS$_NORMAL;
4356     }
4357     return info->fp;
4358 }  /* end of safe_popen */
4359
4360
4361 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4362 PerlIO *
4363 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4364 {
4365     int sts;
4366     TAINT_ENV();
4367     TAINT_PROPER("popen");
4368     PERL_FLUSHALL_FOR_CHILD;
4369     return safe_popen(aTHX_ cmd,mode,&sts);
4370 }
4371
4372 /*}}}*/
4373
4374 /*{{{  I32 my_pclose(PerlIO *fp)*/
4375 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4376 {
4377     pInfo info, last = NULL;
4378     unsigned long int retsts;
4379     int done, iss, n;
4380     int status;
4381
4382     for (info = open_pipes; info != NULL; last = info, info = info->next)
4383         if (info->fp == fp) break;
4384
4385     if (info == NULL) {  /* no such pipe open */
4386       set_errno(ECHILD); /* quoth POSIX */
4387       set_vaxc_errno(SS$_NONEXPR);
4388       return -1;
4389     }
4390
4391     /* If we were writing to a subprocess, insure that someone reading from
4392      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4393      * produce an EOF record in the mailbox.
4394      *
4395      *  well, at least sometimes it *does*, so we have to watch out for
4396      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4397      */
4398      if (info->fp) {
4399         if (!info->useFILE
4400 #if defined(USE_ITHREADS)
4401           && my_perl
4402 #endif
4403           && PL_perlio_fd_refcnt)
4404             PerlIO_flush(info->fp);
4405         else
4406             fflush((FILE *)info->fp);
4407     }
4408
4409     _ckvmssts(sys$setast(0));
4410      info->closing = TRUE;
4411      done = info->done && info->in_done && info->out_done && info->err_done;
4412      /* hanging on write to Perl's input? cancel it */
4413      if (info->mode == 'r' && info->out && !info->out_done) {
4414         if (info->out->chan_out) {
4415             _ckvmssts(sys$cancel(info->out->chan_out));
4416             if (!info->out->chan_in) {   /* EOF generation, need AST */
4417                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4418             }
4419         }
4420      }
4421      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4422          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4423                            0, 0, 0, 0, 0, 0));
4424     _ckvmssts(sys$setast(1));
4425     if (info->fp) {
4426      if (!info->useFILE
4427 #if defined(USE_ITHREADS)
4428          && my_perl
4429 #endif
4430          && PL_perlio_fd_refcnt)
4431         PerlIO_close(info->fp);
4432      else
4433         fclose((FILE *)info->fp);
4434     }
4435      /*
4436         we have to wait until subprocess completes, but ALSO wait until all
4437         the i/o completes...otherwise we'll be freeing the "info" structure
4438         that the i/o ASTs could still be using...
4439      */
4440
4441      while (!done) {
4442          _ckvmssts(sys$setast(0));
4443          done = info->done && info->in_done && info->out_done && info->err_done;
4444          if (!done) _ckvmssts(sys$clref(pipe_ef));
4445          _ckvmssts(sys$setast(1));
4446          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4447      }
4448      retsts = info->completion;
4449
4450     /* remove from list of open pipes */
4451     _ckvmssts(sys$setast(0));
4452     if (last) last->next = info->next;
4453     else open_pipes = info->next;
4454     _ckvmssts(sys$setast(1));
4455
4456     /* free buffers and structures */
4457
4458     if (info->in) {
4459         if (info->in->buf) {
4460             n = info->in->bufsize * sizeof(char);
4461             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4462         }
4463         n = sizeof(Pipe);
4464         _ckvmssts(lib$free_vm(&n, &info->in));
4465     }
4466     if (info->out) {
4467         if (info->out->buf) {
4468             n = info->out->bufsize * sizeof(char);
4469             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4470         }
4471         n = sizeof(Pipe);
4472         _ckvmssts(lib$free_vm(&n, &info->out));
4473     }
4474     if (info->err) {
4475         if (info->err->buf) {
4476             n = info->err->bufsize * sizeof(char);
4477             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4478         }
4479         n = sizeof(Pipe);
4480         _ckvmssts(lib$free_vm(&n, &info->err));
4481     }
4482     n = sizeof(Info);
4483     _ckvmssts(lib$free_vm(&n, &info));
4484
4485     return retsts;
4486
4487 }  /* end of my_pclose() */
4488
4489 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4490   /* Roll our own prototype because we want this regardless of whether
4491    * _VMS_WAIT is defined.
4492    */
4493   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4494 #endif
4495 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4496    created with popen(); otherwise partially emulate waitpid() unless
4497    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4498    Also check processes not considered by the CRTL waitpid().
4499  */
4500 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4501 Pid_t
4502 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4503 {
4504     pInfo info;
4505     int done;
4506     int sts;
4507     int j;
4508
4509     if (statusp) *statusp = 0;
4510
4511     for (info = open_pipes; info != NULL; info = info->next)
4512         if (info->pid == pid) break;
4513
4514     if (info != NULL) {  /* we know about this child */
4515       while (!info->done) {
4516           _ckvmssts(sys$setast(0));
4517           done = info->done;
4518           if (!done) _ckvmssts(sys$clref(pipe_ef));
4519           _ckvmssts(sys$setast(1));
4520           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4521       }
4522
4523       if (statusp) *statusp = info->completion;
4524       return pid;
4525     }
4526
4527     /* child that already terminated? */
4528
4529     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4530         if (closed_list[j].pid == pid) {
4531             if (statusp) *statusp = closed_list[j].completion;
4532             return pid;
4533         }
4534     }
4535
4536     /* fall through if this child is not one of our own pipe children */
4537
4538 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4539
4540       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4541        * in 7.2 did we get a version that fills in the VMS completion
4542        * status as Perl has always tried to do.
4543        */
4544
4545       sts = __vms_waitpid( pid, statusp, flags );
4546
4547       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4548          return sts;
4549
4550       /* If the real waitpid tells us the child does not exist, we
4551        * fall through here to implement waiting for a child that
4552        * was created by some means other than exec() (say, spawned
4553        * from DCL) or to wait for a process that is not a subprocess
4554        * of the current process.
4555        */
4556
4557 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4558
4559     {
4560       $DESCRIPTOR(intdsc,"0 00:00:01");
4561       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4562       unsigned long int pidcode = JPI$_PID, mypid;
4563       unsigned long int interval[2];
4564       unsigned int jpi_iosb[2];
4565       struct itmlst_3 jpilist[2] = {
4566           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4567           {                      0,         0,                 0, 0}
4568       };
4569
4570       if (pid <= 0) {
4571         /* Sorry folks, we don't presently implement rooting around for
4572            the first child we can find, and we definitely don't want to
4573            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4574          */
4575         set_errno(ENOTSUP);
4576         return -1;
4577       }
4578
4579       /* Get the owner of the child so I can warn if it's not mine. If the
4580        * process doesn't exist or I don't have the privs to look at it,
4581        * I can go home early.
4582        */
4583       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4584       if (sts & 1) sts = jpi_iosb[0];
4585       if (!(sts & 1)) {
4586         switch (sts) {
4587             case SS$_NONEXPR:
4588                 set_errno(ECHILD);
4589                 break;
4590             case SS$_NOPRIV:
4591                 set_errno(EACCES);
4592                 break;
4593             default:
4594                 _ckvmssts(sts);
4595         }
4596         set_vaxc_errno(sts);
4597         return -1;
4598       }
4599
4600       if (ckWARN(WARN_EXEC)) {
4601         /* remind folks they are asking for non-standard waitpid behavior */
4602         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4603         if (ownerpid != mypid)
4604           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4605                       "waitpid: process %x is not a child of process %x",
4606                       pid,mypid);
4607       }
4608
4609       /* simply check on it once a second until it's not there anymore. */
4610
4611       _ckvmssts(sys$bintim(&intdsc,interval));
4612       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4613             _ckvmssts(sys$schdwk(0,0,interval,0));
4614             _ckvmssts(sys$hiber());
4615       }
4616       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4617
4618       _ckvmssts(sts);
4619       return pid;
4620     }
4621 }  /* end of waitpid() */
4622 /*}}}*/
4623 /*}}}*/
4624 /*}}}*/
4625
4626 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4627 char *
4628 my_gconvert(double val, int ndig, int trail, char *buf)
4629 {
4630   static char __gcvtbuf[DBL_DIG+1];
4631   char *loc;
4632
4633   loc = buf ? buf : __gcvtbuf;
4634
4635 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4636   if (val < 1) {
4637     sprintf(loc,"%.*g",ndig,val);
4638     return loc;
4639   }
4640 #endif
4641
4642   if (val) {
4643     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4644     return gcvt(val,ndig,loc);
4645   }
4646   else {
4647     loc[0] = '0'; loc[1] = '\0';
4648     return loc;
4649   }
4650
4651 }
4652 /*}}}*/
4653
4654 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4655 static int rms_free_search_context(struct FAB * fab)
4656 {
4657 struct NAM * nam;
4658
4659     nam = fab->fab$l_nam;
4660     nam->nam$b_nop |= NAM$M_SYNCHK;
4661     nam->nam$l_rlf = NULL;
4662     fab->fab$b_dns = 0;
4663     return sys$parse(fab, NULL, NULL);
4664 }
4665
4666 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4667 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4668 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4669 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4670 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4671 #define rms_nam_esll(nam) nam.nam$b_esl
4672 #define rms_nam_esl(nam) nam.nam$b_esl
4673 #define rms_nam_name(nam) nam.nam$l_name
4674 #define rms_nam_namel(nam) nam.nam$l_name
4675 #define rms_nam_type(nam) nam.nam$l_type
4676 #define rms_nam_typel(nam) nam.nam$l_type
4677 #define rms_nam_ver(nam) nam.nam$l_ver
4678 #define rms_nam_verl(nam) nam.nam$l_ver
4679 #define rms_nam_rsll(nam) nam.nam$b_rsl
4680 #define rms_nam_rsl(nam) nam.nam$b_rsl
4681 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4682 #define rms_set_fna(fab, nam, name, size) \
4683         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4684 #define rms_get_fna(fab, nam) fab.fab$l_fna
4685 #define rms_set_dna(fab, nam, name, size) \
4686         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4687 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4688 #define rms_set_esa(fab, nam, name, size) \
4689         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4690 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4691         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4692 #define rms_set_rsa(nam, name, size) \
4693         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4694 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4695         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4696 #define rms_nam_name_type_l_size(nam) \
4697         (nam.nam$b_name + nam.nam$b_type)
4698 #else
4699 static int rms_free_search_context(struct FAB * fab)
4700 {
4701 struct NAML * nam;
4702
4703     nam = fab->fab$l_naml;
4704     nam->naml$b_nop |= NAM$M_SYNCHK;
4705     nam->naml$l_rlf = NULL;
4706     nam->naml$l_long_defname_size = 0;
4707
4708     fab->fab$b_dns = 0;
4709     return sys$parse(fab, NULL, NULL);
4710 }
4711
4712 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4713 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4714 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4715 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4716 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4717 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4718 #define rms_nam_esl(nam) nam.naml$b_esl
4719 #define rms_nam_name(nam) nam.naml$l_name
4720 #define rms_nam_namel(nam) nam.naml$l_long_name
4721 #define rms_nam_type(nam) nam.naml$l_type
4722 #define rms_nam_typel(nam) nam.naml$l_long_type
4723 #define rms_nam_ver(nam) nam.naml$l_ver
4724 #define rms_nam_verl(nam) nam.naml$l_long_ver
4725 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4726 #define rms_nam_rsl(nam) nam.naml$b_rsl
4727 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4728 #define rms_set_fna(fab, nam, name, size) \
4729         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4730         nam.naml$l_long_filename_size = size; \
4731         nam.naml$l_long_filename = name;}
4732 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4733 #define rms_set_dna(fab, nam, name, size) \
4734         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4735         nam.naml$l_long_defname_size = size; \
4736         nam.naml$l_long_defname = name; }
4737 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4738 #define rms_set_esa(fab, nam, name, size) \
4739         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4740         nam.naml$l_long_expand_alloc = size; \
4741         nam.naml$l_long_expand = name; }
4742 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4743         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4744         nam.naml$l_long_expand = l_name; \
4745         nam.naml$l_long_expand_alloc = l_size; }
4746 #define rms_set_rsa(nam, name, size) \
4747         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4748         nam.naml$l_long_result = name; \
4749         nam.naml$l_long_result_alloc = size; }
4750 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4751         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4752         nam.naml$l_long_result = l_name; \
4753         nam.naml$l_long_result_alloc = l_size; }
4754 #define rms_nam_name_type_l_size(nam) \
4755         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4756 #endif
4757
4758
4759 /* rms_erase
4760  * The CRTL for 8.3 and later can create symbolic links in any mode,
4761  * however in 8.3 the unlink/remove/delete routines will only properly handle
4762  * them if one of the PCP modes is active.
4763  */
4764 static int rms_erase(const char * vmsname)
4765 {
4766   int status;
4767   struct FAB myfab = cc$rms_fab;
4768   rms_setup_nam(mynam);
4769
4770   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4771   rms_bind_fab_nam(myfab, mynam);
4772
4773   /* Are we removing all versions? */
4774   if (vms_unlink_all_versions == 1) {
4775     const char * defspec = ";*";
4776     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4777   }
4778
4779 #ifdef NAML$M_OPEN_SPECIAL
4780   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4781 #endif
4782
4783   status = SYS$ERASE(&myfab, 0, 0);
4784
4785   return status;
4786 }
4787
4788
4789 static int
4790 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4791                     const struct dsc$descriptor_s * vms_dst_dsc,
4792                     unsigned long flags)
4793 {
4794     /*  VMS and UNIX handle file permissions differently and the
4795      * the same ACL trick may be needed for renaming files,
4796      * especially if they are directories.
4797      */
4798
4799    /* todo: get kill_file and rename to share common code */
4800    /* I can not find online documentation for $change_acl
4801     * it appears to be replaced by $set_security some time ago */
4802
4803 const unsigned int access_mode = 0;
4804 $DESCRIPTOR(obj_file_dsc,"FILE");
4805 char *vmsname;
4806 char *rslt;
4807 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4808 int aclsts, fndsts, rnsts = -1;
4809 unsigned int ctx = 0;
4810 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4811 struct dsc$descriptor_s * clean_dsc;
4812
4813 struct myacedef {
4814     unsigned char myace$b_length;
4815     unsigned char myace$b_type;
4816     unsigned short int myace$w_flags;
4817     unsigned long int myace$l_access;
4818     unsigned long int myace$l_ident;
4819 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4820              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4821              0},
4822              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4823
4824 struct item_list_3
4825         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4826                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4827                       {0,0,0,0}},
4828         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4829         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4830                      {0,0,0,0}};
4831
4832
4833     /* Expand the input spec using RMS, since we do not want to put
4834      * ACLs on the target of a symbolic link */
4835     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4836     if (vmsname == NULL)
4837         return SS$_INSFMEM;
4838
4839     rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
4840                         vmsname,
4841                         0,
4842                         NULL,
4843                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
4844                         NULL,
4845                         NULL);
4846     if (rslt == NULL) {
4847         PerlMem_free(vmsname);
4848         return SS$_INSFMEM;
4849     }
4850
4851     /* So we get our own UIC to use as a rights identifier,
4852      * and the insert an ACE at the head of the ACL which allows us
4853      * to delete the file.
4854      */
4855     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4856
4857     fildsc.dsc$w_length = strlen(vmsname);
4858     fildsc.dsc$a_pointer = vmsname;
4859     ctx = 0;
4860     newace.myace$l_ident = oldace.myace$l_ident;
4861     rnsts = SS$_ABORT;
4862
4863     /* Grab any existing ACEs with this identifier in case we fail */
4864     clean_dsc = &fildsc;
4865     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4866                                &fildsc,
4867                                NULL,
4868                                OSS$M_WLOCK,
4869                                findlst,
4870                                &ctx,
4871                                &access_mode);
4872
4873     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4874         /* Add the new ACE . . . */
4875
4876         /* if the sys$get_security succeeded, then ctx is valid, and the
4877          * object/file descriptors will be ignored.  But otherwise they
4878          * are needed
4879          */
4880         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4881                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4882         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4883             set_errno(EVMSERR);
4884             set_vaxc_errno(aclsts);
4885             PerlMem_free(vmsname);
4886             return aclsts;
4887         }
4888
4889         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4890                                 NULL, NULL,
4891                                 &flags,
4892                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4893
4894         if ($VMS_STATUS_SUCCESS(rnsts)) {
4895             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4896         }
4897
4898         /* Put things back the way they were. */
4899         ctx = 0;
4900         aclsts = sys$get_security(&obj_file_dsc,
4901                                   clean_dsc,
4902                                   NULL,
4903                                   OSS$M_WLOCK,
4904                                   findlst,
4905                                   &ctx,
4906                                   &access_mode);
4907
4908         if ($VMS_STATUS_SUCCESS(aclsts)) {
4909         int sec_flags;
4910
4911             sec_flags = 0;
4912             if (!$VMS_STATUS_SUCCESS(fndsts))
4913                 sec_flags = OSS$M_RELCTX;
4914
4915             /* Get rid of the new ACE */
4916             aclsts = sys$set_security(NULL, NULL, NULL,
4917                                   sec_flags, dellst, &ctx, &access_mode);
4918
4919             /* If there was an old ACE, put it back */
4920             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
4921                 addlst[0].bufadr = &oldace;
4922                 aclsts = sys$set_security(NULL, NULL, NULL,
4923                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
4924                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4925                     set_errno(EVMSERR);
4926                     set_vaxc_errno(aclsts);
4927                     rnsts = aclsts;
4928                 }
4929             } else {
4930             int aclsts2;
4931
4932                 /* Try to clear the lock on the ACL list */
4933                 aclsts2 = sys$set_security(NULL, NULL, NULL,
4934                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
4935
4936                 /* Rename errors are most important */
4937                 if (!$VMS_STATUS_SUCCESS(rnsts))
4938                     aclsts = rnsts;
4939                 set_errno(EVMSERR);
4940                 set_vaxc_errno(aclsts);
4941                 rnsts = aclsts;
4942             }
4943         }
4944         else {
4945             if (aclsts != SS$_ACLEMPTY)
4946                 rnsts = aclsts;
4947         }
4948     }
4949     else
4950         rnsts = fndsts;
4951
4952     PerlMem_free(vmsname);
4953     return rnsts;
4954 }
4955
4956
4957 /*{{{int rename(const char *, const char * */
4958 /* Not exactly what X/Open says to do, but doing it absolutely right
4959  * and efficiently would require a lot more work.  This should be close
4960  * enough to pass all but the most strict X/Open compliance test.
4961  */
4962 int
4963 Perl_rename(pTHX_ const char *src, const char * dst)
4964 {
4965 int retval;
4966 int pre_delete = 0;
4967 int src_sts;
4968 int dst_sts;
4969 Stat_t src_st;
4970 Stat_t dst_st;
4971
4972     /* Validate the source file */
4973     src_sts = flex_lstat(src, &src_st);
4974     if (src_sts != 0) {
4975
4976         /* No source file or other problem */
4977         return src_sts;
4978     }
4979
4980     dst_sts = flex_lstat(dst, &dst_st);
4981     if (dst_sts == 0) {
4982
4983         if (dst_st.st_dev != src_st.st_dev) {
4984             /* Must be on the same device */
4985             errno = EXDEV;
4986             return -1;
4987         }
4988
4989         /* VMS_INO_T_COMPARE is true if the inodes are different
4990          * to match the output of memcmp
4991          */
4992
4993         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
4994             /* That was easy, the files are the same! */
4995             return 0;
4996         }
4997
4998         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
4999             /* If source is a directory, so must be dest */
5000                 errno = EISDIR;
5001                 return -1;
5002         }
5003
5004     }
5005
5006
5007     if ((dst_sts == 0) &&
5008         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5009
5010         /* We have issues here if vms_unlink_all_versions is set
5011          * If the destination exists, and is not a directory, then
5012          * we must delete in advance.
5013          *
5014          * If the src is a directory, then we must always pre-delete
5015          * the destination.
5016          *
5017          * If we successfully delete the dst in advance, and the rename fails
5018          * X/Open requires that errno be EIO.
5019          *
5020          */
5021
5022         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5023             int d_sts;
5024             d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5025             if (d_sts != 0)
5026                 return d_sts;
5027
5028             /* We killed the destination, so only errno now is EIO */
5029             pre_delete = 1;
5030         }
5031     }
5032
5033     /* Originally the idea was to call the CRTL rename() and only
5034      * try the lib$rename_file if it failed.
5035      * It turns out that there are too many variants in what the
5036      * the CRTL rename might do, so only use lib$rename_file
5037      */
5038     retval = -1;
5039
5040     {
5041         /* Is the source and dest both in VMS format */
5042         /* if the source is a directory, then need to fileify */
5043         /*  and dest must be a directory or non-existant. */
5044
5045         char * vms_src;
5046         char * vms_dst;
5047         int sts;
5048         char * ret_str;
5049         unsigned long flags;
5050         struct dsc$descriptor_s old_file_dsc;
5051         struct dsc$descriptor_s new_file_dsc;
5052
5053         /* We need to modify the src and dst depending
5054          * on if one or more of them are directories.
5055          */
5056
5057         vms_src = PerlMem_malloc(VMS_MAXRSS);
5058         if (vms_src == NULL)
5059             _ckvmssts(SS$_INSFMEM);
5060
5061         /* Source is always a VMS format file */
5062         ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5063         if (ret_str == NULL) {
5064             PerlMem_free(vms_src);
5065             errno = EIO;
5066             return -1;
5067         }
5068
5069         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5070         if (vms_dst == NULL)
5071             _ckvmssts(SS$_INSFMEM);
5072
5073         if (S_ISDIR(src_st.st_mode)) {
5074         char * ret_str;
5075         char * vms_dir_file;
5076
5077             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5078             if (vms_dir_file == NULL)
5079                 _ckvmssts(SS$_INSFMEM);
5080
5081             /* The source must be a file specification */
5082             ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5083             if (ret_str == NULL) {
5084                 PerlMem_free(vms_src);
5085                 PerlMem_free(vms_dst);
5086                 PerlMem_free(vms_dir_file);
5087                 errno = EIO;
5088                 return -1;
5089             }
5090             PerlMem_free(vms_src);
5091             vms_src = vms_dir_file;
5092
5093             /* If the dest is a directory, we must remove it
5094             if (dst_sts == 0) {
5095                 int d_sts;
5096                 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5097                 if (d_sts != 0) {
5098                     PerlMem_free(vms_src);
5099                     PerlMem_free(vms_dst);
5100                     errno = EIO;
5101                     return sts;
5102                 }
5103
5104                 pre_delete = 1;
5105             }
5106
5107            /* The dest must be a VMS file specification */
5108            ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5109            if (ret_str == NULL) {
5110                 PerlMem_free(vms_src);
5111                 PerlMem_free(vms_dst);
5112                 errno = EIO;
5113                 return -1;
5114            }
5115
5116             /* The source must be a file specification */
5117             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5118             if (vms_dir_file == NULL)
5119                 _ckvmssts(SS$_INSFMEM);
5120
5121             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5122             if (ret_str == NULL) {
5123                 PerlMem_free(vms_src);
5124                 PerlMem_free(vms_dst);
5125                 PerlMem_free(vms_dir_file);
5126                 errno = EIO;
5127                 return -1;
5128             }
5129             PerlMem_free(vms_dst);
5130             vms_dst = vms_dir_file;
5131
5132         } else {
5133             /* File to file or file to new dir */
5134
5135             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5136                 /* VMS pathify a dir target */
5137                 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5138                 if (ret_str == NULL) {
5139                     PerlMem_free(vms_src);
5140                     PerlMem_free(vms_dst);
5141                     errno = EIO;
5142                     return -1;
5143                 }
5144             } else {
5145
5146                 /* fileify a target VMS file specification */
5147                 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5148                 if (ret_str == NULL) {
5149                     PerlMem_free(vms_src);
5150                     PerlMem_free(vms_dst);
5151                     errno = EIO;
5152                     return -1;
5153                 }
5154             }
5155         }
5156
5157         old_file_dsc.dsc$a_pointer = vms_src;
5158         old_file_dsc.dsc$w_length = strlen(vms_src);
5159         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5160         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5161
5162         new_file_dsc.dsc$a_pointer = vms_dst;
5163         new_file_dsc.dsc$w_length = strlen(vms_dst);
5164         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5165         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5166
5167         flags = 0;
5168 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5169         flags |= 2; /* LIB$M_FIL_LONG_NAMES */
5170 #endif
5171
5172         sts = lib$rename_file(&old_file_dsc,
5173                               &new_file_dsc,
5174                               NULL, NULL,
5175                               &flags,
5176                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5177         if (!$VMS_STATUS_SUCCESS(sts)) {
5178
5179            /* We could have failed because VMS style permissions do not
5180             * permit renames that UNIX will allow.  Just like the hack
5181             * in for kill_file.
5182             */
5183            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5184         }
5185
5186         PerlMem_free(vms_src);
5187         PerlMem_free(vms_dst);
5188         if (!$VMS_STATUS_SUCCESS(sts)) {
5189             errno = EIO;
5190             return -1;
5191         }
5192         retval = 0;
5193     }
5194
5195     if (vms_unlink_all_versions) {
5196         /* Now get rid of any previous versions of the source file that
5197          * might still exist
5198          */
5199         int save_errno;
5200         save_errno = errno;
5201         src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5202         errno = save_errno;
5203     }
5204
5205     /* We deleted the destination, so must force the error to be EIO */
5206     if ((retval != 0) && (pre_delete != 0))
5207         errno = EIO;
5208
5209     return retval;
5210 }
5211 /*}}}*/
5212
5213
5214 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5215 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5216  * to expand file specification.  Allows for a single default file
5217  * specification and a simple mask of options.  If outbuf is non-NULL,
5218  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5219  * the resultant file specification is placed.  If outbuf is NULL, the
5220  * resultant file specification is placed into a static buffer.
5221  * The third argument, if non-NULL, is taken to be a default file
5222  * specification string.  The fourth argument is unused at present.
5223  * rmesexpand() returns the address of the resultant string if
5224  * successful, and NULL on error.
5225  *
5226  * New functionality for previously unused opts value:
5227  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5228  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5229  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5230  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5231  */
5232 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5233
5234 static char *
5235 mp_do_rmsexpand
5236    (pTHX_ const char *filespec,
5237     char *outbuf,
5238     int ts,
5239     const char *defspec,
5240     unsigned opts,
5241     int * fs_utf8,
5242     int * dfs_utf8)
5243 {
5244   static char __rmsexpand_retbuf[VMS_MAXRSS];
5245   char * vmsfspec, *tmpfspec;
5246   char * esa, *cp, *out = NULL;
5247   char * tbuf;
5248   char * esal = NULL;
5249   char * outbufl;
5250   struct FAB myfab = cc$rms_fab;
5251   rms_setup_nam(mynam);
5252   STRLEN speclen;
5253   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5254   int sts;
5255
5256   /* temp hack until UTF8 is actually implemented */
5257   if (fs_utf8 != NULL)
5258     *fs_utf8 = 0;
5259
5260   if (!filespec || !*filespec) {
5261     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5262     return NULL;
5263   }
5264   if (!outbuf) {
5265     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5266     else    outbuf = __rmsexpand_retbuf;
5267   }
5268
5269   vmsfspec = NULL;
5270   tmpfspec = NULL;
5271   outbufl = NULL;
5272
5273   isunix = 0;
5274   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5275     isunix = is_unix_filespec(filespec);
5276     if (isunix) {
5277       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5278       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
5279       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
5280         PerlMem_free(vmsfspec);
5281         if (out)
5282            Safefree(out);
5283         return NULL;
5284       }
5285       filespec = vmsfspec;
5286
5287       /* Unless we are forcing to VMS format, a UNIX input means
5288        * UNIX output, and that requires long names to be used
5289        */
5290       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5291         opts |= PERL_RMSEXPAND_M_LONG;
5292       else {
5293         isunix = 0;
5294       }
5295     }
5296   }
5297
5298   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5299   rms_bind_fab_nam(myfab, mynam);
5300
5301   if (defspec && *defspec) {
5302     int t_isunix;
5303     t_isunix = is_unix_filespec(defspec);
5304     if (t_isunix) {
5305       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5306       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5307       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
5308         PerlMem_free(tmpfspec);
5309         if (vmsfspec != NULL)
5310             PerlMem_free(vmsfspec);
5311         if (out)
5312            Safefree(out);
5313         return NULL;
5314       }
5315       defspec = tmpfspec;
5316     }
5317     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5318   }
5319
5320   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5321   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5322 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5323   esal = PerlMem_malloc(VMS_MAXRSS);
5324   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5325 #endif
5326   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5327
5328   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5329     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
5330   }
5331   else {
5332 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5333     outbufl = PerlMem_malloc(VMS_MAXRSS);
5334     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
5335     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5336 #else
5337     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
5338 #endif
5339   }
5340
5341 #ifdef NAM$M_NO_SHORT_UPCASE
5342   if (decc_efs_case_preserve)
5343     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5344 #endif
5345
5346    /* We may not want to follow symbolic links */
5347 #ifdef NAML$M_OPEN_SPECIAL
5348   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5349     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5350 #endif
5351
5352   /* First attempt to parse as an existing file */
5353   retsts = sys$parse(&myfab,0,0);
5354   if (!(retsts & STS$K_SUCCESS)) {
5355
5356     /* Could not find the file, try as syntax only if error is not fatal */
5357     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5358     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5359       retsts = sys$parse(&myfab,0,0);
5360       if (retsts & STS$K_SUCCESS) goto expanded;
5361     }
5362
5363      /* Still could not parse the file specification */
5364     /*----------------------------------------------*/
5365     sts = rms_free_search_context(&myfab); /* Free search context */
5366     if (out) Safefree(out);
5367     if (tmpfspec != NULL)
5368         PerlMem_free(tmpfspec);
5369     if (vmsfspec != NULL)
5370         PerlMem_free(vmsfspec);
5371     if (outbufl != NULL)
5372         PerlMem_free(outbufl);
5373     PerlMem_free(esa);
5374     if (esal != NULL)
5375         PerlMem_free(esal);
5376     set_vaxc_errno(retsts);
5377     if      (retsts == RMS$_PRV) set_errno(EACCES);
5378     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5379     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5380     else                         set_errno(EVMSERR);
5381     return NULL;
5382   }
5383   retsts = sys$search(&myfab,0,0);
5384   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5385     sts = rms_free_search_context(&myfab); /* Free search context */
5386     if (out) Safefree(out);
5387     if (tmpfspec != NULL)
5388         PerlMem_free(tmpfspec);
5389     if (vmsfspec != NULL)
5390         PerlMem_free(vmsfspec);
5391     if (outbufl != NULL)
5392         PerlMem_free(outbufl);
5393     PerlMem_free(esa);
5394     if (esal != NULL)
5395         PerlMem_free(esal);
5396     set_vaxc_errno(retsts);
5397     if      (retsts == RMS$_PRV) set_errno(EACCES);
5398     else                         set_errno(EVMSERR);
5399     return NULL;
5400   }
5401
5402   /* If the input filespec contained any lowercase characters,
5403    * downcase the result for compatibility with Unix-minded code. */
5404   expanded:
5405   if (!decc_efs_case_preserve) {
5406     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5407       if (islower(*tbuf)) { haslower = 1; break; }
5408   }
5409
5410    /* Is a long or a short name expected */
5411   /*------------------------------------*/
5412   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5413     if (rms_nam_rsll(mynam)) {
5414         tbuf = outbuf;
5415         speclen = rms_nam_rsll(mynam);
5416     }
5417     else {
5418         tbuf = esal; /* Not esa */
5419         speclen = rms_nam_esll(mynam);
5420     }
5421   }
5422   else {
5423     if (rms_nam_rsl(mynam)) {
5424         tbuf = outbuf;
5425         speclen = rms_nam_rsl(mynam);
5426     }
5427     else {
5428         tbuf = esa; /* Not esal */
5429         speclen = rms_nam_esl(mynam);
5430     }
5431   }
5432   tbuf[speclen] = '\0';
5433
5434   /* Trim off null fields added by $PARSE
5435    * If type > 1 char, must have been specified in original or default spec
5436    * (not true for version; $SEARCH may have added version of existing file).
5437    */
5438   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5439   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5440     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5441              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5442   }
5443   else {
5444     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5445              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5446   }
5447   if (trimver || trimtype) {
5448     if (defspec && *defspec) {
5449       char *defesal = NULL;
5450       defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5451       if (defesal != NULL) {
5452         struct FAB deffab = cc$rms_fab;
5453         rms_setup_nam(defnam);
5454
5455         rms_bind_fab_nam(deffab, defnam);
5456
5457         /* Cast ok */
5458         rms_set_fna
5459             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5460
5461         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
5462
5463         rms_clear_nam_nop(defnam);
5464         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5465 #ifdef NAM$M_NO_SHORT_UPCASE
5466         if (decc_efs_case_preserve)
5467           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5468 #endif
5469 #ifdef NAML$M_OPEN_SPECIAL
5470         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5471           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5472 #endif
5473         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5474           if (trimver) {
5475              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5476           }
5477           if (trimtype) {
5478             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5479           }
5480         }
5481         PerlMem_free(defesal);
5482       }
5483     }
5484     if (trimver) {
5485       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5486         if (*(rms_nam_verl(mynam)) != '\"')
5487           speclen = rms_nam_verl(mynam) - tbuf;
5488       }
5489       else {
5490         if (*(rms_nam_ver(mynam)) != '\"')
5491           speclen = rms_nam_ver(mynam) - tbuf;
5492       }
5493     }
5494     if (trimtype) {
5495       /* If we didn't already trim version, copy down */
5496       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5497         if (speclen > rms_nam_verl(mynam) - tbuf)
5498           memmove
5499            (rms_nam_typel(mynam),
5500             rms_nam_verl(mynam),
5501             speclen - (rms_nam_verl(mynam) - tbuf));
5502           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5503       }
5504       else {
5505         if (speclen > rms_nam_ver(mynam) - tbuf)
5506           memmove
5507            (rms_nam_type(mynam),
5508             rms_nam_ver(mynam),
5509             speclen - (rms_nam_ver(mynam) - tbuf));
5510           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5511       }
5512     }
5513   }
5514
5515    /* Done with these copies of the input files */
5516   /*-------------------------------------------*/
5517   if (vmsfspec != NULL)
5518         PerlMem_free(vmsfspec);
5519   if (tmpfspec != NULL)
5520         PerlMem_free(tmpfspec);
5521
5522   /* If we just had a directory spec on input, $PARSE "helpfully"
5523    * adds an empty name and type for us */
5524   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5525     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5526         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5527         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5528       speclen = rms_nam_namel(mynam) - tbuf;
5529   }
5530   else {
5531     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5532         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5533         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5534       speclen = rms_nam_name(mynam) - tbuf;
5535   }
5536
5537   /* Posix format specifications must have matching quotes */
5538   if (speclen < (VMS_MAXRSS - 1)) {
5539     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5540       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5541         tbuf[speclen] = '\"';
5542         speclen++;
5543       }
5544     }
5545   }
5546   tbuf[speclen] = '\0';
5547   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5548
5549   /* Have we been working with an expanded, but not resultant, spec? */
5550   /* Also, convert back to Unix syntax if necessary. */
5551
5552   if (!rms_nam_rsll(mynam)) {
5553     if (isunix) {
5554       if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5555         if (out) Safefree(out);
5556         if (esal != NULL)
5557             PerlMem_free(esal);
5558         PerlMem_free(esa);
5559         if (outbufl != NULL)
5560             PerlMem_free(outbufl);
5561         return NULL;
5562       }
5563     }
5564     else strcpy(outbuf, tbuf);
5565   }
5566   else if (isunix) {
5567     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5568     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5569     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5570         if (out) Safefree(out);
5571         PerlMem_free(esa);
5572         if (esal != NULL)
5573             PerlMem_free(esal);
5574         PerlMem_free(tmpfspec);
5575         if (outbufl != NULL)
5576             PerlMem_free(outbufl);
5577         return NULL;
5578     }
5579     strcpy(outbuf,tmpfspec);
5580     PerlMem_free(tmpfspec);
5581   }
5582
5583   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5584   sts = rms_free_search_context(&myfab); /* Free search context */
5585   PerlMem_free(esa);
5586   if (esal != NULL)
5587      PerlMem_free(esal);
5588   if (outbufl != NULL)
5589      PerlMem_free(outbufl);
5590   return outbuf;
5591 }
5592 /*}}}*/
5593 /* External entry points */
5594 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5595 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5596 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5597 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5598 char *Perl_rmsexpand_utf8
5599   (pTHX_ const char *spec, char *buf, const char *def,
5600    unsigned opt, int * fs_utf8, int * dfs_utf8)
5601 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5602 char *Perl_rmsexpand_utf8_ts
5603   (pTHX_ const char *spec, char *buf, const char *def,
5604    unsigned opt, int * fs_utf8, int * dfs_utf8)
5605 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5606
5607
5608 /*
5609 ** The following routines are provided to make life easier when
5610 ** converting among VMS-style and Unix-style directory specifications.
5611 ** All will take input specifications in either VMS or Unix syntax. On
5612 ** failure, all return NULL.  If successful, the routines listed below
5613 ** return a pointer to a buffer containing the appropriately
5614 ** reformatted spec (and, therefore, subsequent calls to that routine
5615 ** will clobber the result), while the routines of the same names with
5616 ** a _ts suffix appended will return a pointer to a mallocd string
5617 ** containing the appropriately reformatted spec.
5618 ** In all cases, only explicit syntax is altered; no check is made that
5619 ** the resulting string is valid or that the directory in question
5620 ** actually exists.
5621 **
5622 **   fileify_dirspec() - convert a directory spec into the name of the
5623 **     directory file (i.e. what you can stat() to see if it's a dir).
5624 **     The style (VMS or Unix) of the result is the same as the style
5625 **     of the parameter passed in.
5626 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5627 **     what you prepend to a filename to indicate what directory it's in).
5628 **     The style (VMS or Unix) of the result is the same as the style
5629 **     of the parameter passed in.
5630 **   tounixpath() - convert a directory spec into a Unix-style path.
5631 **   tovmspath() - convert a directory spec into a VMS-style path.
5632 **   tounixspec() - convert any file spec into a Unix-style file spec.
5633 **   tovmsspec() - convert any file spec into a VMS-style spec.
5634 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5635 **
5636 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5637 ** Permission is given to distribute this code as part of the Perl
5638 ** standard distribution under the terms of the GNU General Public
5639 ** License or the Perl Artistic License.  Copies of each may be
5640 ** found in the Perl standard distribution.
5641  */
5642
5643 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5644 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5645 {
5646     static char __fileify_retbuf[VMS_MAXRSS];
5647     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5648     char *retspec, *cp1, *cp2, *lastdir;
5649     char *trndir, *vmsdir;
5650     unsigned short int trnlnm_iter_count;
5651     int sts;
5652     if (utf8_fl != NULL)
5653         *utf8_fl = 0;
5654
5655     if (!dir || !*dir) {
5656       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5657     }
5658     dirlen = strlen(dir);
5659     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5660     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5661       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5662         dir = "/sys$disk";
5663         dirlen = 9;
5664       }
5665       else
5666         dirlen = 1;
5667     }
5668     if (dirlen > (VMS_MAXRSS - 1)) {
5669       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5670       return NULL;
5671     }
5672     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5673     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5674     if (!strpbrk(dir+1,"/]>:")  &&
5675         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5676       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5677       trnlnm_iter_count = 0;
5678       while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5679         trnlnm_iter_count++;
5680         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5681       }
5682       dirlen = strlen(trndir);
5683     }
5684     else {
5685       strncpy(trndir,dir,dirlen);
5686       trndir[dirlen] = '\0';
5687     }
5688
5689     /* At this point we are done with *dir and use *trndir which is a
5690      * copy that can be modified.  *dir must not be modified.
5691      */
5692
5693     /* If we were handed a rooted logical name or spec, treat it like a
5694      * simple directory, so that
5695      *    $ Define myroot dev:[dir.]
5696      *    ... do_fileify_dirspec("myroot",buf,1) ...
5697      * does something useful.
5698      */
5699     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5700       trndir[--dirlen] = '\0';
5701       trndir[dirlen-1] = ']';
5702     }
5703     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5704       trndir[--dirlen] = '\0';
5705       trndir[dirlen-1] = '>';
5706     }
5707
5708     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5709       /* If we've got an explicit filename, we can just shuffle the string. */
5710       if (*(cp1+1)) hasfilename = 1;
5711       /* Similarly, we can just back up a level if we've got multiple levels
5712          of explicit directories in a VMS spec which ends with directories. */
5713       else {
5714         for (cp2 = cp1; cp2 > trndir; cp2--) {
5715           if (*cp2 == '.') {
5716             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5717 /* fix-me, can not scan EFS file specs backward like this */
5718               *cp2 = *cp1; *cp1 = '\0';
5719               hasfilename = 1;
5720               break;
5721             }
5722           }
5723           if (*cp2 == '[' || *cp2 == '<') break;
5724         }
5725       }
5726     }
5727
5728     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5729     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5730     cp1 = strpbrk(trndir,"]:>");
5731     if (hasfilename || !cp1) { /* Unix-style path or filename */
5732       if (trndir[0] == '.') {
5733         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5734           PerlMem_free(trndir);
5735           PerlMem_free(vmsdir);
5736           return do_fileify_dirspec("[]",buf,ts,NULL);
5737         }
5738         else if (trndir[1] == '.' &&
5739                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5740           PerlMem_free(trndir);
5741           PerlMem_free(vmsdir);
5742           return do_fileify_dirspec("[-]",buf,ts,NULL);
5743         }
5744       }
5745       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5746         dirlen -= 1;                 /* to last element */
5747         lastdir = strrchr(trndir,'/');
5748       }
5749       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5750         /* If we have "/." or "/..", VMSify it and let the VMS code
5751          * below expand it, rather than repeating the code to handle
5752          * relative components of a filespec here */
5753         do {
5754           if (*(cp1+2) == '.') cp1++;
5755           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5756             char * ret_chr;
5757             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5758                 PerlMem_free(trndir);
5759                 PerlMem_free(vmsdir);
5760                 return NULL;
5761             }
5762             if (strchr(vmsdir,'/') != NULL) {
5763               /* If do_tovmsspec() returned it, it must have VMS syntax
5764                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5765                * the time to check this here only so we avoid a recursion
5766                * loop; otherwise, gigo.
5767                */
5768               PerlMem_free(trndir);
5769               PerlMem_free(vmsdir);
5770               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5771               return NULL;
5772             }
5773             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5774                 PerlMem_free(trndir);
5775                 PerlMem_free(vmsdir);
5776                 return NULL;
5777             }
5778             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5779             PerlMem_free(trndir);
5780             PerlMem_free(vmsdir);
5781             return ret_chr;
5782           }
5783           cp1++;
5784         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5785         lastdir = strrchr(trndir,'/');
5786       }
5787       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5788         char * ret_chr;
5789         /* Ditto for specs that end in an MFD -- let the VMS code
5790          * figure out whether it's a real device or a rooted logical. */
5791
5792         /* This should not happen any more.  Allowing the fake /000000
5793          * in a UNIX pathname causes all sorts of problems when trying
5794          * to run in UNIX emulation.  So the VMS to UNIX conversions
5795          * now remove the fake /000000 directories.
5796          */
5797
5798         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5799         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5800             PerlMem_free(trndir);
5801             PerlMem_free(vmsdir);
5802             return NULL;
5803         }
5804         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5805             PerlMem_free(trndir);
5806             PerlMem_free(vmsdir);
5807             return NULL;
5808         }
5809         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5810         PerlMem_free(trndir);
5811         PerlMem_free(vmsdir);
5812         return ret_chr;
5813       }
5814       else {
5815
5816         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5817              !(lastdir = cp1 = strrchr(trndir,']')) &&
5818              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5819         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5820           int ver; char *cp3;
5821
5822           /* For EFS or ODS-5 look for the last dot */
5823           if (decc_efs_charset) {
5824               cp2 = strrchr(cp1,'.');
5825           }
5826           if (vms_process_case_tolerant) {
5827               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5828                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5829                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5830                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5831                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5832                             (ver || *cp3)))))) {
5833                   PerlMem_free(trndir);
5834                   PerlMem_free(vmsdir);
5835                   set_errno(ENOTDIR);
5836                   set_vaxc_errno(RMS$_DIR);
5837                   return NULL;
5838               }
5839           }
5840           else {
5841               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5842                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5843                   !*(cp2+3) || *(cp2+3) != 'R' ||
5844                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5845                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5846                             (ver || *cp3)))))) {
5847                  PerlMem_free(trndir);
5848                  PerlMem_free(vmsdir);
5849                  set_errno(ENOTDIR);
5850                  set_vaxc_errno(RMS$_DIR);
5851                  return NULL;
5852               }
5853           }
5854           dirlen = cp2 - trndir;
5855         }
5856       }
5857
5858       retlen = dirlen + 6;
5859       if (buf) retspec = buf;
5860       else if (ts) Newx(retspec,retlen+1,char);
5861       else retspec = __fileify_retbuf;
5862       memcpy(retspec,trndir,dirlen);
5863       retspec[dirlen] = '\0';
5864
5865       /* We've picked up everything up to the directory file name.
5866          Now just add the type and version, and we're set. */
5867       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5868         strcat(retspec,".dir;1");
5869       else
5870         strcat(retspec,".DIR;1");
5871       PerlMem_free(trndir);
5872       PerlMem_free(vmsdir);
5873       return retspec;
5874     }
5875     else {  /* VMS-style directory spec */
5876
5877       char *esa, term, *cp;
5878       unsigned long int sts, cmplen, haslower = 0;
5879       unsigned int nam_fnb;
5880       char * nam_type;
5881       struct FAB dirfab = cc$rms_fab;
5882       rms_setup_nam(savnam);
5883       rms_setup_nam(dirnam);
5884
5885       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5886       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5887       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5888       rms_bind_fab_nam(dirfab, dirnam);
5889       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5890       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5891 #ifdef NAM$M_NO_SHORT_UPCASE
5892       if (decc_efs_case_preserve)
5893         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5894 #endif
5895
5896       for (cp = trndir; *cp; cp++)
5897         if (islower(*cp)) { haslower = 1; break; }
5898       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5899         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5900           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5901           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5902         }
5903         if (!sts) {
5904           PerlMem_free(esa);
5905           PerlMem_free(trndir);
5906           PerlMem_free(vmsdir);
5907           set_errno(EVMSERR);
5908           set_vaxc_errno(dirfab.fab$l_sts);
5909           return NULL;
5910         }
5911       }
5912       else {
5913         savnam = dirnam;
5914         /* Does the file really exist? */
5915         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5916           /* Yes; fake the fnb bits so we'll check type below */
5917         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5918         }
5919         else { /* No; just work with potential name */
5920           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5921           else {
5922             int fab_sts;
5923             fab_sts = dirfab.fab$l_sts;
5924             sts = rms_free_search_context(&dirfab);
5925             PerlMem_free(esa);
5926             PerlMem_free(trndir);
5927             PerlMem_free(vmsdir);
5928             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5929             return NULL;
5930           }
5931         }
5932       }
5933       esa[rms_nam_esll(dirnam)] = '\0';
5934       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5935         cp1 = strchr(esa,']');
5936         if (!cp1) cp1 = strchr(esa,'>');
5937         if (cp1) {  /* Should always be true */
5938           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5939           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5940         }
5941       }
5942       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5943         /* Yep; check version while we're at it, if it's there. */
5944         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5945         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5946           /* Something other than .DIR[;1].  Bzzt. */
5947           sts = rms_free_search_context(&dirfab);
5948           PerlMem_free(esa);
5949           PerlMem_free(trndir);
5950           PerlMem_free(vmsdir);
5951           set_errno(ENOTDIR);
5952           set_vaxc_errno(RMS$_DIR);
5953           return NULL;
5954         }
5955       }
5956
5957       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5958         /* They provided at least the name; we added the type, if necessary, */
5959         if (buf) retspec = buf;                            /* in sys$parse() */
5960         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5961         else retspec = __fileify_retbuf;
5962         strcpy(retspec,esa);
5963         sts = rms_free_search_context(&dirfab);
5964         PerlMem_free(trndir);
5965         PerlMem_free(esa);
5966         PerlMem_free(vmsdir);
5967         return retspec;
5968       }
5969       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5970         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5971         *cp1 = '\0';
5972         rms_nam_esll(dirnam) -= 9;
5973       }
5974       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5975       if (cp1 == NULL) { /* should never happen */
5976         sts = rms_free_search_context(&dirfab);
5977         PerlMem_free(trndir);
5978         PerlMem_free(esa);
5979         PerlMem_free(vmsdir);
5980         return NULL;
5981       }
5982       term = *cp1;
5983       *cp1 = '\0';
5984       retlen = strlen(esa);
5985       cp1 = strrchr(esa,'.');
5986       /* ODS-5 directory specifications can have extra "." in them. */
5987       /* Fix-me, can not scan EFS file specifications backwards */
5988       while (cp1 != NULL) {
5989         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5990           break;
5991         else {
5992            cp1--;
5993            while ((cp1 > esa) && (*cp1 != '.'))
5994              cp1--;
5995         }
5996         if (cp1 == esa)
5997           cp1 = NULL;
5998       }
5999
6000       if ((cp1) != NULL) {
6001         /* There's more than one directory in the path.  Just roll back. */
6002         *cp1 = term;
6003         if (buf) retspec = buf;
6004         else if (ts) Newx(retspec,retlen+7,char);
6005         else retspec = __fileify_retbuf;
6006         strcpy(retspec,esa);
6007       }
6008       else {
6009         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6010           /* Go back and expand rooted logical name */
6011           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6012 #ifdef NAM$M_NO_SHORT_UPCASE
6013           if (decc_efs_case_preserve)
6014             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6015 #endif
6016           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6017             sts = rms_free_search_context(&dirfab);
6018             PerlMem_free(esa);
6019             PerlMem_free(trndir);
6020             PerlMem_free(vmsdir);
6021             set_errno(EVMSERR);
6022             set_vaxc_errno(dirfab.fab$l_sts);
6023             return NULL;
6024           }
6025           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
6026           if (buf) retspec = buf;
6027           else if (ts) Newx(retspec,retlen+16,char);
6028           else retspec = __fileify_retbuf;
6029           cp1 = strstr(esa,"][");
6030           if (!cp1) cp1 = strstr(esa,"]<");
6031           dirlen = cp1 - esa;
6032           memcpy(retspec,esa,dirlen);
6033           if (!strncmp(cp1+2,"000000]",7)) {
6034             retspec[dirlen-1] = '\0';
6035             /* fix-me Not full ODS-5, just extra dots in directories for now */
6036             cp1 = retspec + dirlen - 1;
6037             while (cp1 > retspec)
6038             {
6039               if (*cp1 == '[')
6040                 break;
6041               if (*cp1 == '.') {
6042                 if (*(cp1-1) != '^')
6043                   break;
6044               }
6045               cp1--;
6046             }
6047             if (*cp1 == '.') *cp1 = ']';
6048             else {
6049               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6050               memmove(cp1+1,"000000]",7);
6051             }
6052           }
6053           else {
6054             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6055             retspec[retlen] = '\0';
6056             /* Convert last '.' to ']' */
6057             cp1 = retspec+retlen-1;
6058             while (*cp != '[') {
6059               cp1--;
6060               if (*cp1 == '.') {
6061                 /* Do not trip on extra dots in ODS-5 directories */
6062                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6063                 break;
6064               }
6065             }
6066             if (*cp1 == '.') *cp1 = ']';
6067             else {
6068               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6069               memmove(cp1+1,"000000]",7);
6070             }
6071           }
6072         }
6073         else {  /* This is a top-level dir.  Add the MFD to the path. */
6074           if (buf) retspec = buf;
6075           else if (ts) Newx(retspec,retlen+16,char);
6076           else retspec = __fileify_retbuf;
6077           cp1 = esa;
6078           cp2 = retspec;
6079           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6080           strcpy(cp2,":[000000]");
6081           cp1 += 2;
6082           strcpy(cp2+9,cp1);
6083         }
6084       }
6085       sts = rms_free_search_context(&dirfab);
6086       /* We've set up the string up through the filename.  Add the
6087          type and version, and we're done. */
6088       strcat(retspec,".DIR;1");
6089
6090       /* $PARSE may have upcased filespec, so convert output to lower
6091        * case if input contained any lowercase characters. */
6092       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6093       PerlMem_free(trndir);
6094       PerlMem_free(esa);
6095       PerlMem_free(vmsdir);
6096       return retspec;
6097     }
6098 }  /* end of do_fileify_dirspec() */
6099 /*}}}*/
6100 /* External entry points */
6101 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6102 { return do_fileify_dirspec(dir,buf,0,NULL); }
6103 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6104 { return do_fileify_dirspec(dir,buf,1,NULL); }
6105 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6106 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6107 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6108 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6109
6110 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6111 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6112 {
6113     static char __pathify_retbuf[VMS_MAXRSS];
6114     unsigned long int retlen;
6115     char *retpath, *cp1, *cp2, *trndir;
6116     unsigned short int trnlnm_iter_count;
6117     STRLEN trnlen;
6118     int sts;
6119     if (utf8_fl != NULL)
6120         *utf8_fl = 0;
6121
6122     if (!dir || !*dir) {
6123       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6124     }
6125
6126     trndir = PerlMem_malloc(VMS_MAXRSS);
6127     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
6128     if (*dir) strcpy(trndir,dir);
6129     else getcwd(trndir,VMS_MAXRSS - 1);
6130
6131     trnlnm_iter_count = 0;
6132     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6133            && my_trnlnm(trndir,trndir,0)) {
6134       trnlnm_iter_count++;
6135       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6136       trnlen = strlen(trndir);
6137
6138       /* Trap simple rooted lnms, and return lnm:[000000] */
6139       if (!strcmp(trndir+trnlen-2,".]")) {
6140         if (buf) retpath = buf;
6141         else if (ts) Newx(retpath,strlen(dir)+10,char);
6142         else retpath = __pathify_retbuf;
6143         strcpy(retpath,dir);
6144         strcat(retpath,":[000000]");
6145         PerlMem_free(trndir);
6146         return retpath;
6147       }
6148     }
6149
6150     /* At this point we do not work with *dir, but the copy in
6151      * *trndir that is modifiable.
6152      */
6153
6154     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6155       if (*trndir == '.' && (*(trndir+1) == '\0' ||
6156                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6157         retlen = 2 + (*(trndir+1) != '\0');
6158       else {
6159         if ( !(cp1 = strrchr(trndir,'/')) &&
6160              !(cp1 = strrchr(trndir,']')) &&
6161              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6162         if ((cp2 = strchr(cp1,'.')) != NULL &&
6163             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
6164              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
6165               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6166               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6167           int ver; char *cp3;
6168
6169           /* For EFS or ODS-5 look for the last dot */
6170           if (decc_efs_charset) {
6171             cp2 = strrchr(cp1,'.');
6172           }
6173           if (vms_process_case_tolerant) {
6174               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6175                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6176                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6177                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6178                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6179                             (ver || *cp3)))))) {
6180                 PerlMem_free(trndir);
6181                 set_errno(ENOTDIR);
6182                 set_vaxc_errno(RMS$_DIR);
6183                 return NULL;
6184               }
6185           }
6186           else {
6187               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6188                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6189                   !*(cp2+3) || *(cp2+3) != 'R' ||
6190                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6191                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6192                             (ver || *cp3)))))) {
6193                 PerlMem_free(trndir);
6194                 set_errno(ENOTDIR);
6195                 set_vaxc_errno(RMS$_DIR);
6196                 return NULL;
6197               }
6198           }
6199           retlen = cp2 - trndir + 1;
6200         }
6201         else {  /* No file type present.  Treat the filename as a directory. */
6202           retlen = strlen(trndir) + 1;
6203         }
6204       }
6205       if (buf) retpath = buf;
6206       else if (ts) Newx(retpath,retlen+1,char);
6207       else retpath = __pathify_retbuf;
6208       strncpy(retpath, trndir, retlen-1);
6209       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6210         retpath[retlen-1] = '/';      /* with '/', add it. */
6211         retpath[retlen] = '\0';
6212       }
6213       else retpath[retlen-1] = '\0';
6214     }
6215     else {  /* VMS-style directory spec */
6216       char *esa, *cp;
6217       unsigned long int sts, cmplen, haslower;
6218       struct FAB dirfab = cc$rms_fab;
6219       int dirlen;
6220       rms_setup_nam(savnam);
6221       rms_setup_nam(dirnam);
6222
6223       /* If we've got an explicit filename, we can just shuffle the string. */
6224       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6225              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
6226         if ((cp2 = strchr(cp1,'.')) != NULL) {
6227           int ver; char *cp3;
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         }
6255         else {  /* No file type, so just draw name into directory part */
6256           for (cp2 = cp1; *cp2; cp2++) ;
6257         }
6258         *cp2 = *cp1;
6259         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
6260         *cp1 = '.';
6261         /* We've now got a VMS 'path'; fall through */
6262       }
6263
6264       dirlen = strlen(trndir);
6265       if (trndir[dirlen-1] == ']' ||
6266           trndir[dirlen-1] == '>' ||
6267           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6268         if (buf) retpath = buf;
6269         else if (ts) Newx(retpath,strlen(trndir)+1,char);
6270         else retpath = __pathify_retbuf;
6271         strcpy(retpath,trndir);
6272         PerlMem_free(trndir);
6273         return retpath;
6274       }
6275       rms_set_fna(dirfab, dirnam, trndir, dirlen);
6276       esa = PerlMem_malloc(VMS_MAXRSS);
6277       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
6278       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6279       rms_bind_fab_nam(dirfab, dirnam);
6280       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
6281 #ifdef NAM$M_NO_SHORT_UPCASE
6282       if (decc_efs_case_preserve)
6283           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6284 #endif
6285
6286       for (cp = trndir; *cp; cp++)
6287         if (islower(*cp)) { haslower = 1; break; }
6288
6289       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6290         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6291           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6292           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6293         }
6294         if (!sts) {
6295           PerlMem_free(trndir);
6296           PerlMem_free(esa);
6297           set_errno(EVMSERR);
6298           set_vaxc_errno(dirfab.fab$l_sts);
6299           return NULL;
6300         }
6301       }
6302       else {
6303         savnam = dirnam;
6304         /* Does the file really exist? */
6305         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6306           if (dirfab.fab$l_sts != RMS$_FNF) {
6307             int sts1;
6308             sts1 = rms_free_search_context(&dirfab);
6309             PerlMem_free(trndir);
6310             PerlMem_free(esa);
6311             set_errno(EVMSERR);
6312             set_vaxc_errno(dirfab.fab$l_sts);
6313             return NULL;
6314           }
6315           dirnam = savnam; /* No; just work with potential name */
6316         }
6317       }
6318       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6319         /* Yep; check version while we're at it, if it's there. */
6320         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6321         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6322           int sts2;
6323           /* Something other than .DIR[;1].  Bzzt. */
6324           sts2 = rms_free_search_context(&dirfab);
6325           PerlMem_free(trndir);
6326           PerlMem_free(esa);
6327           set_errno(ENOTDIR);
6328           set_vaxc_errno(RMS$_DIR);
6329           return NULL;
6330         }
6331       }
6332       /* OK, the type was fine.  Now pull any file name into the
6333          directory path. */
6334       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6335       else {
6336         cp1 = strrchr(esa,'>');
6337         *(rms_nam_typel(dirnam)) = '>';
6338       }
6339       *cp1 = '.';
6340       *(rms_nam_typel(dirnam) + 1) = '\0';
6341       retlen = (rms_nam_typel(dirnam)) - esa + 2;
6342       if (buf) retpath = buf;
6343       else if (ts) Newx(retpath,retlen,char);
6344       else retpath = __pathify_retbuf;
6345       strcpy(retpath,esa);
6346       PerlMem_free(esa);
6347       sts = rms_free_search_context(&dirfab);
6348       /* $PARSE may have upcased filespec, so convert output to lower
6349        * case if input contained any lowercase characters. */
6350       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6351     }
6352
6353     PerlMem_free(trndir);
6354     return retpath;
6355 }  /* end of do_pathify_dirspec() */
6356 /*}}}*/
6357 /* External entry points */
6358 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6359 { return do_pathify_dirspec(dir,buf,0,NULL); }
6360 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6361 { return do_pathify_dirspec(dir,buf,1,NULL); }
6362 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6363 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6364 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6365 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6366
6367 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6368 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6369 {
6370   static char __tounixspec_retbuf[VMS_MAXRSS];
6371   char *dirend, *rslt, *cp1, *cp3, *tmp;
6372   const char *cp2;
6373   int devlen, dirlen, retlen = VMS_MAXRSS;
6374   int expand = 1; /* guarantee room for leading and trailing slashes */
6375   unsigned short int trnlnm_iter_count;
6376   int cmp_rslt;
6377   if (utf8_fl != NULL)
6378     *utf8_fl = 0;
6379
6380   if (spec == NULL) return NULL;
6381   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6382   if (buf) rslt = buf;
6383   else if (ts) {
6384     Newx(rslt, VMS_MAXRSS, char);
6385   }
6386   else rslt = __tounixspec_retbuf;
6387
6388   /* New VMS specific format needs translation
6389    * glob passes filenames with trailing '\n' and expects this preserved.
6390    */
6391   if (decc_posix_compliant_pathnames) {
6392     if (strncmp(spec, "\"^UP^", 5) == 0) {
6393       char * uspec;
6394       char *tunix;
6395       int tunix_len;
6396       int nl_flag;
6397
6398       tunix = PerlMem_malloc(VMS_MAXRSS);
6399       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
6400       strcpy(tunix, spec);
6401       tunix_len = strlen(tunix);
6402       nl_flag = 0;
6403       if (tunix[tunix_len - 1] == '\n') {
6404         tunix[tunix_len - 1] = '\"';
6405         tunix[tunix_len] = '\0';
6406         tunix_len--;
6407         nl_flag = 1;
6408       }
6409       uspec = decc$translate_vms(tunix);
6410       PerlMem_free(tunix);
6411       if ((int)uspec > 0) {
6412         strcpy(rslt,uspec);
6413         if (nl_flag) {
6414           strcat(rslt,"\n");
6415         }
6416         else {
6417           /* If we can not translate it, makemaker wants as-is */
6418           strcpy(rslt, spec);
6419         }
6420         return rslt;
6421       }
6422     }
6423   }
6424
6425   cmp_rslt = 0; /* Presume VMS */
6426   cp1 = strchr(spec, '/');
6427   if (cp1 == NULL)
6428     cmp_rslt = 0;
6429
6430     /* Look for EFS ^/ */
6431     if (decc_efs_charset) {
6432       while (cp1 != NULL) {
6433         cp2 = cp1 - 1;
6434         if (*cp2 != '^') {
6435           /* Found illegal VMS, assume UNIX */
6436           cmp_rslt = 1;
6437           break;
6438         }
6439       cp1++;
6440       cp1 = strchr(cp1, '/');
6441     }
6442   }
6443
6444   /* Look for "." and ".." */
6445   if (decc_filename_unix_report) {
6446     if (spec[0] == '.') {
6447       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6448         cmp_rslt = 1;
6449       }
6450       else {
6451         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6452           cmp_rslt = 1;
6453         }
6454       }
6455     }
6456   }
6457   /* This is already UNIX or at least nothing VMS understands */
6458   if (cmp_rslt) {
6459     strcpy(rslt,spec);
6460     return rslt;
6461   }
6462
6463   cp1 = rslt;
6464   cp2 = spec;
6465   dirend = strrchr(spec,']');
6466   if (dirend == NULL) dirend = strrchr(spec,'>');
6467   if (dirend == NULL) dirend = strchr(spec,':');
6468   if (dirend == NULL) {
6469     strcpy(rslt,spec);
6470     return rslt;
6471   }
6472
6473   /* Special case 1 - sys$posix_root = / */
6474 #if __CRTL_VER >= 70000000
6475   if (!decc_disable_posix_root) {
6476     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6477       *cp1 = '/';
6478       cp1++;
6479       cp2 = cp2 + 15;
6480       }
6481   }
6482 #endif
6483
6484   /* Special case 2 - Convert NLA0: to /dev/null */
6485 #if __CRTL_VER < 70000000
6486   cmp_rslt = strncmp(spec,"NLA0:", 5);
6487   if (cmp_rslt != 0)
6488      cmp_rslt = strncmp(spec,"nla0:", 5);
6489 #else
6490   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6491 #endif
6492   if (cmp_rslt == 0) {
6493     strcpy(rslt, "/dev/null");
6494     cp1 = cp1 + 9;
6495     cp2 = cp2 + 5;
6496     if (spec[6] != '\0') {
6497       cp1[9] == '/';
6498       cp1++;
6499       cp2++;
6500     }
6501   }
6502
6503    /* Also handle special case "SYS$SCRATCH:" */
6504 #if __CRTL_VER < 70000000
6505   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6506   if (cmp_rslt != 0)
6507      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6508 #else
6509   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6510 #endif
6511   tmp = PerlMem_malloc(VMS_MAXRSS);
6512   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6513   if (cmp_rslt == 0) {
6514   int islnm;
6515
6516     islnm = my_trnlnm(tmp, "TMP", 0);
6517     if (!islnm) {
6518       strcpy(rslt, "/tmp");
6519       cp1 = cp1 + 4;
6520       cp2 = cp2 + 12;
6521       if (spec[12] != '\0') {
6522         cp1[4] == '/';
6523         cp1++;
6524         cp2++;
6525       }
6526     }
6527   }
6528
6529   if (*cp2 != '[' && *cp2 != '<') {
6530     *(cp1++) = '/';
6531   }
6532   else {  /* the VMS spec begins with directories */
6533     cp2++;
6534     if (*cp2 == ']' || *cp2 == '>') {
6535       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6536       PerlMem_free(tmp);
6537       return rslt;
6538     }
6539     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6540       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6541         if (ts) Safefree(rslt);
6542         PerlMem_free(tmp);
6543         return NULL;
6544       }
6545       trnlnm_iter_count = 0;
6546       do {
6547         cp3 = tmp;
6548         while (*cp3 != ':' && *cp3) cp3++;
6549         *(cp3++) = '\0';
6550         if (strchr(cp3,']') != NULL) break;
6551         trnlnm_iter_count++;
6552         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6553       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6554       if (ts && !buf &&
6555           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6556         retlen = devlen + dirlen;
6557         Renew(rslt,retlen+1+2*expand,char);
6558         cp1 = rslt;
6559       }
6560       cp3 = tmp;
6561       *(cp1++) = '/';
6562       while (*cp3) {
6563         *(cp1++) = *(cp3++);
6564         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6565             PerlMem_free(tmp);
6566             return NULL; /* No room */
6567         }
6568       }
6569       *(cp1++) = '/';
6570     }
6571     if ((*cp2 == '^')) {
6572         /* EFS file escape, pass the next character as is */
6573         /* Fix me: HEX encoding for Unicode not implemented */
6574         cp2++;
6575     }
6576     else if ( *cp2 == '.') {
6577       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6578         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6579         cp2 += 3;
6580       }
6581       else cp2++;
6582     }
6583   }
6584   PerlMem_free(tmp);
6585   for (; cp2 <= dirend; cp2++) {
6586     if ((*cp2 == '^')) {
6587         /* EFS file escape, pass the next character as is */
6588         /* Fix me: HEX encoding for Unicode not implemented */
6589         *(cp1++) = *(++cp2);
6590         /* An escaped dot stays as is -- don't convert to slash */
6591         if (*cp2 == '.') cp2++;
6592     }
6593     if (*cp2 == ':') {
6594       *(cp1++) = '/';
6595       if (*(cp2+1) == '[') cp2++;
6596     }
6597     else if (*cp2 == ']' || *cp2 == '>') {
6598       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6599     }
6600     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6601       *(cp1++) = '/';
6602       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6603         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6604                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6605         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6606             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6607       }
6608       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6609         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6610         cp2 += 2;
6611       }
6612     }
6613     else if (*cp2 == '-') {
6614       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6615         while (*cp2 == '-') {
6616           cp2++;
6617           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6618         }
6619         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6620           if (ts) Safefree(rslt);                        /* filespecs like */
6621           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6622           return NULL;
6623         }
6624       }
6625       else *(cp1++) = *cp2;
6626     }
6627     else *(cp1++) = *cp2;
6628   }
6629   while (*cp2) {
6630     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6631     *(cp1++) = *(cp2++);
6632   }
6633   *cp1 = '\0';
6634
6635   /* This still leaves /000000/ when working with a
6636    * VMS device root or concealed root.
6637    */
6638   {
6639   int ulen;
6640   char * zeros;
6641
6642       ulen = strlen(rslt);
6643
6644       /* Get rid of "000000/ in rooted filespecs */
6645       if (ulen > 7) {
6646         zeros = strstr(rslt, "/000000/");
6647         if (zeros != NULL) {
6648           int mlen;
6649           mlen = ulen - (zeros - rslt) - 7;
6650           memmove(zeros, &zeros[7], mlen);
6651           ulen = ulen - 7;
6652           rslt[ulen] = '\0';
6653         }
6654       }
6655   }
6656
6657   return rslt;
6658
6659 }  /* end of do_tounixspec() */
6660 /*}}}*/
6661 /* External entry points */
6662 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6663   { return do_tounixspec(spec,buf,0, NULL); }
6664 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6665   { return do_tounixspec(spec,buf,1, NULL); }
6666 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6667   { return do_tounixspec(spec,buf,0, utf8_fl); }
6668 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6669   { return do_tounixspec(spec,buf,1, utf8_fl); }
6670
6671 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6672
6673 /*
6674  This procedure is used to identify if a path is based in either
6675  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6676  it returns the OpenVMS format directory for it.
6677
6678  It is expecting specifications of only '/' or '/xxxx/'
6679
6680  If a posix root does not exist, or 'xxxx' is not a directory
6681  in the posix root, it returns a failure.
6682
6683  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6684
6685  It is used only internally by posix_to_vmsspec_hardway().
6686  */
6687
6688 static int posix_root_to_vms
6689   (char *vmspath, int vmspath_len,
6690    const char *unixpath,
6691    const int * utf8_fl) {
6692 int sts;
6693 struct FAB myfab = cc$rms_fab;
6694 struct NAML mynam = cc$rms_naml;
6695 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6696  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6697 char *esa;
6698 char *vms_delim;
6699 int dir_flag;
6700 int unixlen;
6701
6702     dir_flag = 0;
6703     unixlen = strlen(unixpath);
6704     if (unixlen == 0) {
6705       vmspath[0] = '\0';
6706       return RMS$_FNF;
6707     }
6708
6709 #if __CRTL_VER >= 80200000
6710   /* If not a posix spec already, convert it */
6711   if (decc_posix_compliant_pathnames) {
6712     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6713       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6714     }
6715     else {
6716       /* This is already a VMS specification, no conversion */
6717       unixlen--;
6718       strncpy(vmspath,unixpath, vmspath_len);
6719     }
6720   }
6721   else
6722 #endif
6723   {
6724   int path_len;
6725   int i,j;
6726
6727      /* Check to see if this is under the POSIX root */
6728      if (decc_disable_posix_root) {
6729         return RMS$_FNF;
6730      }
6731
6732      /* Skip leading / */
6733      if (unixpath[0] == '/') {
6734         unixpath++;
6735         unixlen--;
6736      }
6737
6738
6739      strcpy(vmspath,"SYS$POSIX_ROOT:");
6740
6741      /* If this is only the / , or blank, then... */
6742      if (unixpath[0] == '\0') {
6743         /* by definition, this is the answer */
6744         return SS$_NORMAL;
6745      }
6746
6747      /* Need to look up a directory */
6748      vmspath[15] = '[';
6749      vmspath[16] = '\0';
6750
6751      /* Copy and add '^' escape characters as needed */
6752      j = 16;
6753      i = 0;
6754      while (unixpath[i] != 0) {
6755      int k;
6756
6757         j += copy_expand_unix_filename_escape
6758             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6759         i += k;
6760      }
6761
6762      path_len = strlen(vmspath);
6763      if (vmspath[path_len - 1] == '/')
6764         path_len--;
6765      vmspath[path_len] = ']';
6766      path_len++;
6767      vmspath[path_len] = '\0';
6768
6769   }
6770   vmspath[vmspath_len] = 0;
6771   if (unixpath[unixlen - 1] == '/')
6772   dir_flag = 1;
6773   esa = PerlMem_malloc(VMS_MAXRSS);
6774   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6775   myfab.fab$l_fna = vmspath;
6776   myfab.fab$b_fns = strlen(vmspath);
6777   myfab.fab$l_naml = &mynam;
6778   mynam.naml$l_esa = NULL;
6779   mynam.naml$b_ess = 0;
6780   mynam.naml$l_long_expand = esa;
6781   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6782   mynam.naml$l_rsa = NULL;
6783   mynam.naml$b_rss = 0;
6784   if (decc_efs_case_preserve)
6785     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6786 #ifdef NAML$M_OPEN_SPECIAL
6787   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6788 #endif
6789
6790   /* Set up the remaining naml fields */
6791   sts = sys$parse(&myfab);
6792
6793   /* It failed! Try again as a UNIX filespec */
6794   if (!(sts & 1)) {
6795     PerlMem_free(esa);
6796     return sts;
6797   }
6798
6799    /* get the Device ID and the FID */
6800    sts = sys$search(&myfab);
6801    /* on any failure, returned the POSIX ^UP^ filespec */
6802    if (!(sts & 1)) {
6803       PerlMem_free(esa);
6804       return sts;
6805    }
6806    specdsc.dsc$a_pointer = vmspath;
6807    specdsc.dsc$w_length = vmspath_len;
6808
6809    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6810    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6811    sts = lib$fid_to_name
6812       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6813
6814   /* on any failure, returned the POSIX ^UP^ filespec */
6815   if (!(sts & 1)) {
6816      /* This can happen if user does not have permission to read directories */
6817      if (strncmp(unixpath,"\"^UP^",5) != 0)
6818        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6819      else
6820        strcpy(vmspath, unixpath);
6821   }
6822   else {
6823     vmspath[specdsc.dsc$w_length] = 0;
6824
6825     /* Are we expecting a directory? */
6826     if (dir_flag != 0) {
6827     int i;
6828     char *eptr;
6829
6830       eptr = NULL;
6831
6832       i = specdsc.dsc$w_length - 1;
6833       while (i > 0) {
6834       int zercnt;
6835         zercnt = 0;
6836         /* Version must be '1' */
6837         if (vmspath[i--] != '1')
6838           break;
6839         /* Version delimiter is one of ".;" */
6840         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6841           break;
6842         i--;
6843         if (vmspath[i--] != 'R')
6844           break;
6845         if (vmspath[i--] != 'I')
6846           break;
6847         if (vmspath[i--] != 'D')
6848           break;
6849         if (vmspath[i--] != '.')
6850           break;
6851         eptr = &vmspath[i+1];
6852         while (i > 0) {
6853           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6854             if (vmspath[i-1] != '^') {
6855               if (zercnt != 6) {
6856                 *eptr = vmspath[i];
6857                 eptr[1] = '\0';
6858                 vmspath[i] = '.';
6859                 break;
6860               }
6861               else {
6862                 /* Get rid of 6 imaginary zero directory filename */
6863                 vmspath[i+1] = '\0';
6864               }
6865             }
6866           }
6867           if (vmspath[i] == '0')
6868             zercnt++;
6869           else
6870             zercnt = 10;
6871           i--;
6872         }
6873         break;
6874       }
6875     }
6876   }
6877   PerlMem_free(esa);
6878   return sts;
6879 }
6880
6881 /* /dev/mumble needs to be handled special.
6882    /dev/null becomes NLA0:, And there is the potential for other stuff
6883    like /dev/tty which may need to be mapped to something.
6884 */
6885
6886 static int
6887 slash_dev_special_to_vms
6888    (const char * unixptr,
6889     char * vmspath,
6890     int vmspath_len)
6891 {
6892 char * nextslash;
6893 int len;
6894 int cmp;
6895 int islnm;
6896
6897     unixptr += 4;
6898     nextslash = strchr(unixptr, '/');
6899     len = strlen(unixptr);
6900     if (nextslash != NULL)
6901         len = nextslash - unixptr;
6902     cmp = strncmp("null", unixptr, 5);
6903     if (cmp == 0) {
6904         if (vmspath_len >= 6) {
6905             strcpy(vmspath, "_NLA0:");
6906             return SS$_NORMAL;
6907         }
6908     }
6909 }
6910
6911
6912 /* The built in routines do not understand perl's special needs, so
6913     doing a manual conversion from UNIX to VMS
6914
6915     If the utf8_fl is not null and points to a non-zero value, then
6916     treat 8 bit characters as UTF-8.
6917
6918     The sequence starting with '$(' and ending with ')' will be passed
6919     through with out interpretation instead of being escaped.
6920
6921   */
6922 static int posix_to_vmsspec_hardway
6923   (char *vmspath, int vmspath_len,
6924    const char *unixpath,
6925    int dir_flag,
6926    int * utf8_fl) {
6927
6928 char *esa;
6929 const char *unixptr;
6930 const char *unixend;
6931 char *vmsptr;
6932 const char *lastslash;
6933 const char *lastdot;
6934 int unixlen;
6935 int vmslen;
6936 int dir_start;
6937 int dir_dot;
6938 int quoted;
6939 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6940 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6941
6942   if (utf8_fl != NULL)
6943     *utf8_fl = 0;
6944
6945   unixptr = unixpath;
6946   dir_dot = 0;
6947
6948   /* Ignore leading "/" characters */
6949   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6950     unixptr++;
6951   }
6952   unixlen = strlen(unixptr);
6953
6954   /* Do nothing with blank paths */
6955   if (unixlen == 0) {
6956     vmspath[0] = '\0';
6957     return SS$_NORMAL;
6958   }
6959
6960   quoted = 0;
6961   /* This could have a "^UP^ on the front */
6962   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6963     quoted = 1;
6964     unixptr+= 5;
6965     unixlen-= 5;
6966   }
6967
6968   lastslash = strrchr(unixptr,'/');
6969   lastdot = strrchr(unixptr,'.');
6970   unixend = strrchr(unixptr,'\"');
6971   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6972     unixend = unixptr + unixlen;
6973   }
6974
6975   /* last dot is last dot or past end of string */
6976   if (lastdot == NULL)
6977     lastdot = unixptr + unixlen;
6978
6979   /* if no directories, set last slash to beginning of string */
6980   if (lastslash == NULL) {
6981     lastslash = unixptr;
6982   }
6983   else {
6984     /* Watch out for trailing "." after last slash, still a directory */
6985     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6986       lastslash = unixptr + unixlen;
6987     }
6988
6989     /* Watch out for traiing ".." after last slash, still a directory */
6990     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6991       lastslash = unixptr + unixlen;
6992     }
6993
6994     /* dots in directories are aways escaped */
6995     if (lastdot < lastslash)
6996       lastdot = unixptr + unixlen;
6997   }
6998
6999   /* if (unixptr < lastslash) then we are in a directory */
7000
7001   dir_start = 0;
7002
7003   vmsptr = vmspath;
7004   vmslen = 0;
7005
7006   /* Start with the UNIX path */
7007   if (*unixptr != '/') {
7008     /* relative paths */
7009
7010     /* If allowing logical names on relative pathnames, then handle here */
7011     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7012         !decc_posix_compliant_pathnames) {
7013     char * nextslash;
7014     int seg_len;
7015     char * trn;
7016     int islnm;
7017
7018         /* Find the next slash */
7019         nextslash = strchr(unixptr,'/');
7020
7021         esa = PerlMem_malloc(vmspath_len);
7022         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7023
7024         trn = PerlMem_malloc(VMS_MAXRSS);
7025         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7026
7027         if (nextslash != NULL) {
7028
7029             seg_len = nextslash - unixptr;
7030             strncpy(esa, unixptr, seg_len);
7031             esa[seg_len] = 0;
7032         }
7033         else {
7034             strcpy(esa, unixptr);
7035             seg_len = strlen(unixptr);
7036         }
7037         /* trnlnm(section) */
7038         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7039
7040         if (islnm) {
7041             /* Now fix up the directory */
7042
7043             /* Split up the path to find the components */
7044             sts = vms_split_path
7045                   (trn,
7046                    &v_spec,
7047                    &v_len,
7048                    &r_spec,
7049                    &r_len,
7050                    &d_spec,
7051                    &d_len,
7052                    &n_spec,
7053                    &n_len,
7054                    &e_spec,
7055                    &e_len,
7056                    &vs_spec,
7057                    &vs_len);
7058
7059             while (sts == 0) {
7060             char * strt;
7061             int cmp;
7062
7063                 /* A logical name must be a directory  or the full
7064                    specification.  It is only a full specification if
7065                    it is the only component */
7066                 if ((unixptr[seg_len] == '\0') ||
7067                     (unixptr[seg_len+1] == '\0')) {
7068
7069                     /* Is a directory being required? */
7070                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7071                         /* Not a logical name */
7072                         break;
7073                     }
7074
7075
7076                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7077                         /* This must be a directory */
7078                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7079                             strcpy(vmsptr, esa);
7080                             vmslen=strlen(vmsptr);
7081                             vmsptr[vmslen] = ':';
7082                             vmslen++;
7083                             vmsptr[vmslen] = '\0';
7084                             return SS$_NORMAL;
7085                         }
7086                     }
7087
7088                 }
7089
7090
7091                 /* must be dev/directory - ignore version */
7092                 if ((n_len + e_len) != 0)
7093                     break;
7094
7095                 /* transfer the volume */
7096                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7097                     strncpy(vmsptr, v_spec, v_len);
7098                     vmsptr += v_len;
7099                     vmsptr[0] = '\0';
7100                     vmslen += v_len;
7101                 }
7102
7103                 /* unroot the rooted directory */
7104                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7105                     r_spec[0] = '[';
7106                     r_spec[r_len - 1] = ']';
7107
7108                     /* This should not be there, but nothing is perfect */
7109                     if (r_len > 9) {
7110                         cmp = strcmp(&r_spec[1], "000000.");
7111                         if (cmp == 0) {
7112                             r_spec += 7;
7113                             r_spec[7] = '[';
7114                             r_len -= 7;
7115                             if (r_len == 2)
7116                                 r_len = 0;
7117                         }
7118                     }
7119                     if (r_len > 0) {
7120                         strncpy(vmsptr, r_spec, r_len);
7121                         vmsptr += r_len;
7122                         vmslen += r_len;
7123                         vmsptr[0] = '\0';
7124                     }
7125                 }
7126                 /* Bring over the directory. */
7127                 if ((d_len > 0) &&
7128                     ((d_len + vmslen) < vmspath_len)) {
7129                     d_spec[0] = '[';
7130                     d_spec[d_len - 1] = ']';
7131                     if (d_len > 9) {
7132                         cmp = strcmp(&d_spec[1], "000000.");
7133                         if (cmp == 0) {
7134                             d_spec += 7;
7135                             d_spec[7] = '[';
7136                             d_len -= 7;
7137                             if (d_len == 2)
7138                                 d_len = 0;
7139                         }
7140                     }
7141
7142                     if (r_len > 0) {
7143                         /* Remove the redundant root */
7144                         if (r_len > 0) {
7145                             /* remove the ][ */
7146                             vmsptr--;
7147                             vmslen--;
7148                             d_spec++;
7149                             d_len--;
7150                         }
7151                         strncpy(vmsptr, d_spec, d_len);
7152                             vmsptr += d_len;
7153                             vmslen += d_len;
7154                             vmsptr[0] = '\0';
7155                     }
7156                 }
7157                 break;
7158             }
7159         }
7160
7161         PerlMem_free(esa);
7162         PerlMem_free(trn);
7163     }
7164
7165     if (lastslash > unixptr) {
7166     int dotdir_seen;
7167
7168       /* skip leading ./ */
7169       dotdir_seen = 0;
7170       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7171         dotdir_seen = 1;
7172         unixptr++;
7173         unixptr++;
7174       }
7175
7176       /* Are we still in a directory? */
7177       if (unixptr <= lastslash) {
7178         *vmsptr++ = '[';
7179         vmslen = 1;
7180         dir_start = 1;
7181
7182         /* if not backing up, then it is relative forward. */
7183         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7184               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7185           *vmsptr++ = '.';
7186           vmslen++;
7187           dir_dot = 1;
7188           }
7189        }
7190        else {
7191          if (dotdir_seen) {
7192            /* Perl wants an empty directory here to tell the difference
7193             * between a DCL commmand and a filename
7194             */
7195           *vmsptr++ = '[';
7196           *vmsptr++ = ']';
7197           vmslen = 2;
7198         }
7199       }
7200     }
7201     else {
7202       /* Handle two special files . and .. */
7203       if (unixptr[0] == '.') {
7204         if (&unixptr[1] == unixend) {
7205           *vmsptr++ = '[';
7206           *vmsptr++ = ']';
7207           vmslen += 2;
7208           *vmsptr++ = '\0';
7209           return SS$_NORMAL;
7210         }
7211         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7212           *vmsptr++ = '[';
7213           *vmsptr++ = '-';
7214           *vmsptr++ = ']';
7215           vmslen += 3;
7216           *vmsptr++ = '\0';
7217           return SS$_NORMAL;
7218         }
7219       }
7220     }
7221   }
7222   else {        /* Absolute PATH handling */
7223   int sts;
7224   char * nextslash;
7225   int seg_len;
7226     /* Need to find out where root is */
7227
7228     /* In theory, this procedure should never get an absolute POSIX pathname
7229      * that can not be found on the POSIX root.
7230      * In practice, that can not be relied on, and things will show up
7231      * here that are a VMS device name or concealed logical name instead.
7232      * So to make things work, this procedure must be tolerant.
7233      */
7234     esa = PerlMem_malloc(vmspath_len);
7235     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7236
7237     sts = SS$_NORMAL;
7238     nextslash = strchr(&unixptr[1],'/');
7239     seg_len = 0;
7240     if (nextslash != NULL) {
7241     int cmp;
7242       seg_len = nextslash - &unixptr[1];
7243       strncpy(vmspath, unixptr, seg_len + 1);
7244       vmspath[seg_len+1] = 0;
7245       cmp = 1;
7246       if (seg_len == 3) {
7247         cmp = strncmp(vmspath, "dev", 4);
7248         if (cmp == 0) {
7249             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7250             if (sts = SS$_NORMAL)
7251                 return SS$_NORMAL;
7252         }
7253       }
7254       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7255     }
7256
7257     if ($VMS_STATUS_SUCCESS(sts)) {
7258       /* This is verified to be a real path */
7259
7260       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7261       if ($VMS_STATUS_SUCCESS(sts)) {
7262         strcpy(vmspath, esa);
7263         vmslen = strlen(vmspath);
7264         vmsptr = vmspath + vmslen;
7265         unixptr++;
7266         if (unixptr < lastslash) {
7267         char * rptr;
7268           vmsptr--;
7269           *vmsptr++ = '.';
7270           dir_start = 1;
7271           dir_dot = 1;
7272           if (vmslen > 7) {
7273           int cmp;
7274             rptr = vmsptr - 7;
7275             cmp = strcmp(rptr,"000000.");
7276             if (cmp == 0) {
7277               vmslen -= 7;
7278               vmsptr -= 7;
7279               vmsptr[1] = '\0';
7280             } /* removing 6 zeros */
7281           } /* vmslen < 7, no 6 zeros possible */
7282         } /* Not in a directory */
7283       } /* Posix root found */
7284       else {
7285         /* No posix root, fall back to default directory */
7286         strcpy(vmspath, "SYS$DISK:[");
7287         vmsptr = &vmspath[10];
7288         vmslen = 10;
7289         if (unixptr > lastslash) {
7290            *vmsptr = ']';
7291            vmsptr++;
7292            vmslen++;
7293         }
7294         else {
7295            dir_start = 1;
7296         }
7297       }
7298     } /* end of verified real path handling */
7299     else {
7300     int add_6zero;
7301     int islnm;
7302
7303       /* Ok, we have a device or a concealed root that is not in POSIX
7304        * or we have garbage.  Make the best of it.
7305        */
7306
7307       /* Posix to VMS destroyed this, so copy it again */
7308       strncpy(vmspath, &unixptr[1], seg_len);
7309       vmspath[seg_len] = 0;
7310       vmslen = seg_len;
7311       vmsptr = &vmsptr[vmslen];
7312       islnm = 0;
7313
7314       /* Now do we need to add the fake 6 zero directory to it? */
7315       add_6zero = 1;
7316       if ((*lastslash == '/') && (nextslash < lastslash)) {
7317         /* No there is another directory */
7318         add_6zero = 0;
7319       }
7320       else {
7321       int trnend;
7322       int cmp;
7323
7324         /* now we have foo:bar or foo:[000000]bar to decide from */
7325         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7326
7327         if (!islnm && !decc_posix_compliant_pathnames) {
7328
7329             cmp = strncmp("bin", vmspath, 4);
7330             if (cmp == 0) {
7331                 /* bin => SYS$SYSTEM: */
7332                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7333             }
7334             else {
7335                 /* tmp => SYS$SCRATCH: */
7336                 cmp = strncmp("tmp", vmspath, 4);
7337                 if (cmp == 0) {
7338                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7339                 }
7340             }
7341         }
7342
7343         trnend = islnm ? islnm - 1 : 0;
7344
7345         /* if this was a logical name, ']' or '>' must be present */
7346         /* if not a logical name, then assume a device and hope. */
7347         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7348
7349         /* if log name and trailing '.' then rooted - treat as device */
7350         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7351
7352         /* Fix me, if not a logical name, a device lookup should be
7353          * done to see if the device is file structured.  If the device
7354          * is not file structured, the 6 zeros should not be put on.
7355          *
7356          * As it is, perl is occasionally looking for dev:[000000]tty.
7357          * which looks a little strange.
7358          *
7359          * Not that easy to detect as "/dev" may be file structured with
7360          * special device files.
7361          */
7362
7363         if ((add_6zero == 0) && (*nextslash == '/') &&
7364             (&nextslash[1] == unixend)) {
7365           /* No real directory present */
7366           add_6zero = 1;
7367         }
7368       }
7369
7370       /* Put the device delimiter on */
7371       *vmsptr++ = ':';
7372       vmslen++;
7373       unixptr = nextslash;
7374       unixptr++;
7375
7376       /* Start directory if needed */
7377       if (!islnm || add_6zero) {
7378         *vmsptr++ = '[';
7379         vmslen++;
7380         dir_start = 1;
7381       }
7382
7383       /* add fake 000000] if needed */
7384       if (add_6zero) {
7385         *vmsptr++ = '0';
7386         *vmsptr++ = '0';
7387         *vmsptr++ = '0';
7388         *vmsptr++ = '0';
7389         *vmsptr++ = '0';
7390         *vmsptr++ = '0';
7391         *vmsptr++ = ']';
7392         vmslen += 7;
7393         dir_start = 0;
7394       }
7395
7396     } /* non-POSIX translation */
7397     PerlMem_free(esa);
7398   } /* End of relative/absolute path handling */
7399
7400   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7401   int dash_flag;
7402   int in_cnt;
7403   int out_cnt;
7404
7405     dash_flag = 0;
7406
7407     if (dir_start != 0) {
7408
7409       /* First characters in a directory are handled special */
7410       while ((*unixptr == '/') ||
7411              ((*unixptr == '.') &&
7412               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7413                 (&unixptr[1]==unixend)))) {
7414       int loop_flag;
7415
7416         loop_flag = 0;
7417
7418         /* Skip redundant / in specification */
7419         while ((*unixptr == '/') && (dir_start != 0)) {
7420           loop_flag = 1;
7421           unixptr++;
7422           if (unixptr == lastslash)
7423             break;
7424         }
7425         if (unixptr == lastslash)
7426           break;
7427
7428         /* Skip redundant ./ characters */
7429         while ((*unixptr == '.') &&
7430                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7431           loop_flag = 1;
7432           unixptr++;
7433           if (unixptr == lastslash)
7434             break;
7435           if (*unixptr == '/')
7436             unixptr++;
7437         }
7438         if (unixptr == lastslash)
7439           break;
7440
7441         /* Skip redundant ../ characters */
7442         while ((*unixptr == '.') && (unixptr[1] == '.') &&
7443              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7444           /* Set the backing up flag */
7445           loop_flag = 1;
7446           dir_dot = 0;
7447           dash_flag = 1;
7448           *vmsptr++ = '-';
7449           vmslen++;
7450           unixptr++; /* first . */
7451           unixptr++; /* second . */
7452           if (unixptr == lastslash)
7453             break;
7454           if (*unixptr == '/') /* The slash */
7455             unixptr++;
7456         }
7457         if (unixptr == lastslash)
7458           break;
7459
7460         /* To do: Perl expects /.../ to be translated to [...] on VMS */
7461         /* Not needed when VMS is pretending to be UNIX. */
7462
7463         /* Is this loop stuck because of too many dots? */
7464         if (loop_flag == 0) {
7465           /* Exit the loop and pass the rest through */
7466           break;
7467         }
7468       }
7469
7470       /* Are we done with directories yet? */
7471       if (unixptr >= lastslash) {
7472
7473         /* Watch out for trailing dots */
7474         if (dir_dot != 0) {
7475             vmslen --;
7476             vmsptr--;
7477         }
7478         *vmsptr++ = ']';
7479         vmslen++;
7480         dash_flag = 0;
7481         dir_start = 0;
7482         if (*unixptr == '/')
7483           unixptr++;
7484       }
7485       else {
7486         /* Have we stopped backing up? */
7487         if (dash_flag) {
7488           *vmsptr++ = '.';
7489           vmslen++;
7490           dash_flag = 0;
7491           /* dir_start continues to be = 1 */
7492         }
7493         if (*unixptr == '-') {
7494           *vmsptr++ = '^';
7495           *vmsptr++ = *unixptr++;
7496           vmslen += 2;
7497           dir_start = 0;
7498
7499           /* Now are we done with directories yet? */
7500           if (unixptr >= lastslash) {
7501
7502             /* Watch out for trailing dots */
7503             if (dir_dot != 0) {
7504               vmslen --;
7505               vmsptr--;
7506             }
7507
7508             *vmsptr++ = ']';
7509             vmslen++;
7510             dash_flag = 0;
7511             dir_start = 0;
7512           }
7513         }
7514       }
7515     }
7516
7517     /* All done? */
7518     if (unixptr >= unixend)
7519       break;
7520
7521     /* Normal characters - More EFS work probably needed */
7522     dir_start = 0;
7523     dir_dot = 0;
7524
7525     switch(*unixptr) {
7526     case '/':
7527         /* remove multiple / */
7528         while (unixptr[1] == '/') {
7529            unixptr++;
7530         }
7531         if (unixptr == lastslash) {
7532           /* Watch out for trailing dots */
7533           if (dir_dot != 0) {
7534             vmslen --;
7535             vmsptr--;
7536           }
7537           *vmsptr++ = ']';
7538         }
7539         else {
7540           dir_start = 1;
7541           *vmsptr++ = '.';
7542           dir_dot = 1;
7543
7544           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7545           /* Not needed when VMS is pretending to be UNIX. */
7546
7547         }
7548         dash_flag = 0;
7549         if (unixptr != unixend)
7550           unixptr++;
7551         vmslen++;
7552         break;
7553     case '.':
7554         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7555             (&unixptr[1] == unixend)) {
7556           *vmsptr++ = '^';
7557           *vmsptr++ = '.';
7558           vmslen += 2;
7559           unixptr++;
7560
7561           /* trailing dot ==> '^..' on VMS */
7562           if (unixptr == unixend) {
7563             *vmsptr++ = '.';
7564             vmslen++;
7565             unixptr++;
7566           }
7567           break;
7568         }
7569
7570         *vmsptr++ = *unixptr++;
7571         vmslen ++;
7572         break;
7573     case '"':
7574         if (quoted && (&unixptr[1] == unixend)) {
7575             unixptr++;
7576             break;
7577         }
7578         in_cnt = copy_expand_unix_filename_escape
7579                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7580         vmsptr += out_cnt;
7581         unixptr += in_cnt;
7582         break;
7583     case '~':
7584     case ';':
7585     case '\\':
7586     case '?':
7587     case ' ':
7588     default:
7589         in_cnt = copy_expand_unix_filename_escape
7590                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7591         vmsptr += out_cnt;
7592         unixptr += in_cnt;
7593         break;
7594     }
7595   }
7596
7597   /* Make sure directory is closed */
7598   if (unixptr == lastslash) {
7599     char *vmsptr2;
7600     vmsptr2 = vmsptr - 1;
7601
7602     if (*vmsptr2 != ']') {
7603       *vmsptr2--;
7604
7605       /* directories do not end in a dot bracket */
7606       if (*vmsptr2 == '.') {
7607         vmsptr2--;
7608
7609         /* ^. is allowed */
7610         if (*vmsptr2 != '^') {
7611           vmsptr--; /* back up over the dot */
7612         }
7613       }
7614       *vmsptr++ = ']';
7615     }
7616   }
7617   else {
7618     char *vmsptr2;
7619     /* Add a trailing dot if a file with no extension */
7620     vmsptr2 = vmsptr - 1;
7621     if ((vmslen > 1) &&
7622         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7623         (*vmsptr2 != ')') && (*lastdot != '.')) {
7624         *vmsptr++ = '.';
7625         vmslen++;
7626     }
7627   }
7628
7629   *vmsptr = '\0';
7630   return SS$_NORMAL;
7631 }
7632 #endif
7633
7634  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7635 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7636 {
7637 char * result;
7638 int utf8_flag;
7639
7640    /* If a UTF8 flag is being passed, honor it */
7641    utf8_flag = 0;
7642    if (utf8_fl != NULL) {
7643      utf8_flag = *utf8_fl;
7644     *utf8_fl = 0;
7645    }
7646
7647    if (utf8_flag) {
7648      /* If there is a possibility of UTF8, then if any UTF8 characters
7649         are present, then they must be converted to VTF-7
7650       */
7651      result = strcpy(rslt, path); /* FIX-ME */
7652    }
7653    else
7654      result = strcpy(rslt, path);
7655
7656    return result;
7657 }
7658
7659
7660 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7661 static char *mp_do_tovmsspec
7662    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7663   static char __tovmsspec_retbuf[VMS_MAXRSS];
7664   char *rslt, *dirend;
7665   char *lastdot;
7666   char *vms_delim;
7667   register char *cp1;
7668   const char *cp2;
7669   unsigned long int infront = 0, hasdir = 1;
7670   int rslt_len;
7671   int no_type_seen;
7672   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7673   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7674
7675   if (path == NULL) return NULL;
7676   rslt_len = VMS_MAXRSS-1;
7677   if (buf) rslt = buf;
7678   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7679   else rslt = __tovmsspec_retbuf;
7680
7681   /* '.' and '..' are "[]" and "[-]" for a quick check */
7682   if (path[0] == '.') {
7683     if (path[1] == '\0') {
7684       strcpy(rslt,"[]");
7685       if (utf8_flag != NULL)
7686         *utf8_flag = 0;
7687       return rslt;
7688     }
7689     else {
7690       if (path[1] == '.' && path[2] == '\0') {
7691         strcpy(rslt,"[-]");
7692         if (utf8_flag != NULL)
7693            *utf8_flag = 0;
7694         return rslt;
7695       }
7696     }
7697   }
7698
7699    /* Posix specifications are now a native VMS format */
7700   /*--------------------------------------------------*/
7701 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7702   if (decc_posix_compliant_pathnames) {
7703     if (strncmp(path,"\"^UP^",5) == 0) {
7704       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7705       return rslt;
7706     }
7707   }
7708 #endif
7709
7710   /* This is really the only way to see if this is already in VMS format */
7711   sts = vms_split_path
7712        (path,
7713         &v_spec,
7714         &v_len,
7715         &r_spec,
7716         &r_len,
7717         &d_spec,
7718         &d_len,
7719         &n_spec,
7720         &n_len,
7721         &e_spec,
7722         &e_len,
7723         &vs_spec,
7724         &vs_len);
7725   if (sts == 0) {
7726     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7727        replacement, because the above parse just took care of most of
7728        what is needed to do vmspath when the specification is already
7729        in VMS format.
7730
7731        And if it is not already, it is easier to do the conversion as
7732        part of this routine than to call this routine and then work on
7733        the result.
7734      */
7735
7736     /* If VMS punctuation was found, it is already VMS format */
7737     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7738       if (utf8_flag != NULL)
7739         *utf8_flag = 0;
7740       strcpy(rslt, path);
7741       return rslt;
7742     }
7743     /* Now, what to do with trailing "." cases where there is no
7744        extension?  If this is a UNIX specification, and EFS characters
7745        are enabled, then the trailing "." should be converted to a "^.".
7746        But if this was already a VMS specification, then it should be
7747        left alone.
7748
7749        So in the case of ambiguity, leave the specification alone.
7750      */
7751
7752
7753     /* If there is a possibility of UTF8, then if any UTF8 characters
7754         are present, then they must be converted to VTF-7
7755      */
7756     if (utf8_flag != NULL)
7757       *utf8_flag = 0;
7758     strcpy(rslt, path);
7759     return rslt;
7760   }
7761
7762   dirend = strrchr(path,'/');
7763
7764   if (dirend == NULL) {
7765      /* If we get here with no UNIX directory delimiters, then this is
7766         not a complete file specification, either garbage a UNIX glob
7767         specification that can not be converted to a VMS wildcard, or
7768         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7769         so apparently other programs expect this also.
7770
7771         utf8 flag setting needs to be preserved.
7772       */
7773       strcpy(rslt, path);
7774       return rslt;
7775   }
7776
7777 /* If POSIX mode active, handle the conversion */
7778 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7779   if (decc_efs_charset) {
7780     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7781     return rslt;
7782   }
7783 #endif
7784
7785   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7786     if (!*(dirend+2)) dirend +=2;
7787     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7788     if (decc_efs_charset == 0) {
7789       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7790     }
7791   }
7792
7793   cp1 = rslt;
7794   cp2 = path;
7795   lastdot = strrchr(cp2,'.');
7796   if (*cp2 == '/') {
7797     char *trndev;
7798     int islnm, rooted;
7799     STRLEN trnend;
7800
7801     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7802     if (!*(cp2+1)) {
7803       if (decc_disable_posix_root) {
7804         strcpy(rslt,"sys$disk:[000000]");
7805       }
7806       else {
7807         strcpy(rslt,"sys$posix_root:[000000]");
7808       }
7809       if (utf8_flag != NULL)
7810         *utf8_flag = 0;
7811       return rslt;
7812     }
7813     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7814     *cp1 = '\0';
7815     trndev = PerlMem_malloc(VMS_MAXRSS);
7816     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7817     islnm =  my_trnlnm(rslt,trndev,0);
7818
7819      /* DECC special handling */
7820     if (!islnm) {
7821       if (strcmp(rslt,"bin") == 0) {
7822         strcpy(rslt,"sys$system");
7823         cp1 = rslt + 10;
7824         *cp1 = 0;
7825         islnm =  my_trnlnm(rslt,trndev,0);
7826       }
7827       else if (strcmp(rslt,"tmp") == 0) {
7828         strcpy(rslt,"sys$scratch");
7829         cp1 = rslt + 11;
7830         *cp1 = 0;
7831         islnm =  my_trnlnm(rslt,trndev,0);
7832       }
7833       else if (!decc_disable_posix_root) {
7834         strcpy(rslt, "sys$posix_root");
7835         cp1 = rslt + 13;
7836         *cp1 = 0;
7837         cp2 = path;
7838         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7839         islnm =  my_trnlnm(rslt,trndev,0);
7840       }
7841       else if (strcmp(rslt,"dev") == 0) {
7842         if (strncmp(cp2,"/null", 5) == 0) {
7843           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7844             strcpy(rslt,"NLA0");
7845             cp1 = rslt + 4;
7846             *cp1 = 0;
7847             cp2 = cp2 + 5;
7848             islnm =  my_trnlnm(rslt,trndev,0);
7849           }
7850         }
7851       }
7852     }
7853
7854     trnend = islnm ? strlen(trndev) - 1 : 0;
7855     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7856     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7857     /* If the first element of the path is a logical name, determine
7858      * whether it has to be translated so we can add more directories. */
7859     if (!islnm || rooted) {
7860       *(cp1++) = ':';
7861       *(cp1++) = '[';
7862       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7863       else cp2++;
7864     }
7865     else {
7866       if (cp2 != dirend) {
7867         strcpy(rslt,trndev);
7868         cp1 = rslt + trnend;
7869         if (*cp2 != 0) {
7870           *(cp1++) = '.';
7871           cp2++;
7872         }
7873       }
7874       else {
7875         if (decc_disable_posix_root) {
7876           *(cp1++) = ':';
7877           hasdir = 0;
7878         }
7879       }
7880     }
7881     PerlMem_free(trndev);
7882   }
7883   else {
7884     *(cp1++) = '[';
7885     if (*cp2 == '.') {
7886       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7887         cp2 += 2;         /* skip over "./" - it's redundant */
7888         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7889       }
7890       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7891         *(cp1++) = '-';                                 /* "../" --> "-" */
7892         cp2 += 3;
7893       }
7894       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7895                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7896         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7897         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7898         cp2 += 4;
7899       }
7900       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7901         /* Escape the extra dots in EFS file specifications */
7902         *(cp1++) = '^';
7903       }
7904       if (cp2 > dirend) cp2 = dirend;
7905     }
7906     else *(cp1++) = '.';
7907   }
7908   for (; cp2 < dirend; cp2++) {
7909     if (*cp2 == '/') {
7910       if (*(cp2-1) == '/') continue;
7911       if (*(cp1-1) != '.') *(cp1++) = '.';
7912       infront = 0;
7913     }
7914     else if (!infront && *cp2 == '.') {
7915       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7916       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7917       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7918         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7919         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7920         else {  /* back up over previous directory name */
7921           cp1--;
7922           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7923           if (*(cp1-1) == '[') {
7924             memcpy(cp1,"000000.",7);
7925             cp1 += 7;
7926           }
7927         }
7928         cp2 += 2;
7929         if (cp2 == dirend) break;
7930       }
7931       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7932                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7933         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7934         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7935         if (!*(cp2+3)) {
7936           *(cp1++) = '.';  /* Simulate trailing '/' */
7937           cp2 += 2;  /* for loop will incr this to == dirend */
7938         }
7939         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7940       }
7941       else {
7942         if (decc_efs_charset == 0)
7943           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7944         else {
7945           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7946           *(cp1++) = '.';
7947         }
7948       }
7949     }
7950     else {
7951       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7952       if (*cp2 == '.') {
7953         if (decc_efs_charset == 0)
7954           *(cp1++) = '_';
7955         else {
7956           *(cp1++) = '^';
7957           *(cp1++) = '.';
7958         }
7959       }
7960       else                  *(cp1++) =  *cp2;
7961       infront = 1;
7962     }
7963   }
7964   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7965   if (hasdir) *(cp1++) = ']';
7966   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7967   /* fixme for ODS5 */
7968   no_type_seen = 0;
7969   if (cp2 > lastdot)
7970     no_type_seen = 1;
7971   while (*cp2) {
7972     switch(*cp2) {
7973     case '?':
7974         if (decc_efs_charset == 0)
7975           *(cp1++) = '%';
7976         else
7977           *(cp1++) = '?';
7978         cp2++;
7979     case ' ':
7980         *(cp1)++ = '^';
7981         *(cp1)++ = '_';
7982         cp2++;
7983         break;
7984     case '.':
7985         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7986             decc_readdir_dropdotnotype) {
7987           *(cp1)++ = '^';
7988           *(cp1)++ = '.';
7989           cp2++;
7990
7991           /* trailing dot ==> '^..' on VMS */
7992           if (*cp2 == '\0') {
7993             *(cp1++) = '.';
7994             no_type_seen = 0;
7995           }
7996         }
7997         else {
7998           *(cp1++) = *(cp2++);
7999           no_type_seen = 0;
8000         }
8001         break;
8002     case '$':
8003          /* This could be a macro to be passed through */
8004         *(cp1++) = *(cp2++);
8005         if (*cp2 == '(') {
8006         const char * save_cp2;
8007         char * save_cp1;
8008         int is_macro;
8009
8010             /* paranoid check */
8011             save_cp2 = cp2;
8012             save_cp1 = cp1;
8013             is_macro = 0;
8014
8015             /* Test through */
8016             *(cp1++) = *(cp2++);
8017             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8018                 *(cp1++) = *(cp2++);
8019                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8020                     *(cp1++) = *(cp2++);
8021                 }
8022                 if (*cp2 == ')') {
8023                     *(cp1++) = *(cp2++);
8024                     is_macro = 1;
8025                 }
8026             }
8027             if (is_macro == 0) {
8028                 /* Not really a macro - never mind */
8029                 cp2 = save_cp2;
8030                 cp1 = save_cp1;
8031             }
8032         }
8033         break;
8034     case '\"':
8035     case '~':
8036     case '`':
8037     case '!':
8038     case '#':
8039     case '%':
8040     case '^':
8041         /* Don't escape again if following character is
8042          * already something we escape.
8043          */
8044         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8045             *(cp1++) = *(cp2++);
8046             break;
8047         }
8048         /* But otherwise fall through and escape it. */
8049     case '&':
8050     case '(':
8051     case ')':
8052     case '=':
8053     case '+':
8054     case '\'':
8055     case '@':
8056     case '[':
8057     case ']':
8058     case '{':
8059     case '}':
8060     case ':':
8061     case '\\':
8062     case '|':
8063     case '<':
8064     case '>':
8065         *(cp1++) = '^';
8066         *(cp1++) = *(cp2++);
8067         break;
8068     case ';':
8069         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8070          * which is wrong.  UNIX notation should be ".dir." unless
8071          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8072          * changing this behavior could break more things at this time.
8073          * efs character set effectively does not allow "." to be a version
8074          * delimiter as a further complication about changing this.
8075          */
8076         if (decc_filename_unix_report != 0) {
8077           *(cp1++) = '^';
8078         }
8079         *(cp1++) = *(cp2++);
8080         break;
8081     default:
8082         *(cp1++) = *(cp2++);
8083     }
8084   }
8085   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8086   char *lcp1;
8087     lcp1 = cp1;
8088     lcp1--;
8089      /* Fix me for "^]", but that requires making sure that you do
8090       * not back up past the start of the filename
8091       */
8092     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8093       *cp1++ = '.';
8094   }
8095   *cp1 = '\0';
8096
8097   if (utf8_flag != NULL)
8098     *utf8_flag = 0;
8099   return rslt;
8100
8101 }  /* end of do_tovmsspec() */
8102 /*}}}*/
8103 /* External entry points */
8104 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8105   { return do_tovmsspec(path,buf,0,NULL); }
8106 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8107   { return do_tovmsspec(path,buf,1,NULL); }
8108 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8109   { return do_tovmsspec(path,buf,0,utf8_fl); }
8110 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8111   { return do_tovmsspec(path,buf,1,utf8_fl); }
8112
8113 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8114 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8115   static char __tovmspath_retbuf[VMS_MAXRSS];
8116   int vmslen;
8117   char *pathified, *vmsified, *cp;
8118
8119   if (path == NULL) return NULL;
8120   pathified = PerlMem_malloc(VMS_MAXRSS);
8121   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8122   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8123     PerlMem_free(pathified);
8124     return NULL;
8125   }
8126
8127   vmsified = NULL;
8128   if (buf == NULL)
8129      Newx(vmsified, VMS_MAXRSS, char);
8130   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8131     PerlMem_free(pathified);
8132     if (vmsified) Safefree(vmsified);
8133     return NULL;
8134   }
8135   PerlMem_free(pathified);
8136   if (buf) {
8137     return buf;
8138   }
8139   else if (ts) {
8140     vmslen = strlen(vmsified);
8141     Newx(cp,vmslen+1,char);
8142     memcpy(cp,vmsified,vmslen);
8143     cp[vmslen] = '\0';
8144     Safefree(vmsified);
8145     return cp;
8146   }
8147   else {
8148     strcpy(__tovmspath_retbuf,vmsified);
8149     Safefree(vmsified);
8150     return __tovmspath_retbuf;
8151   }
8152
8153 }  /* end of do_tovmspath() */
8154 /*}}}*/
8155 /* External entry points */
8156 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8157   { return do_tovmspath(path,buf,0, NULL); }
8158 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8159   { return do_tovmspath(path,buf,1, NULL); }
8160 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8161   { return do_tovmspath(path,buf,0,utf8_fl); }
8162 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8163   { return do_tovmspath(path,buf,1,utf8_fl); }
8164
8165
8166 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8167 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8168   static char __tounixpath_retbuf[VMS_MAXRSS];
8169   int unixlen;
8170   char *pathified, *unixified, *cp;
8171
8172   if (path == NULL) return NULL;
8173   pathified = PerlMem_malloc(VMS_MAXRSS);
8174   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8175   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8176     PerlMem_free(pathified);
8177     return NULL;
8178   }
8179
8180   unixified = NULL;
8181   if (buf == NULL) {
8182       Newx(unixified, VMS_MAXRSS, char);
8183   }
8184   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8185     PerlMem_free(pathified);
8186     if (unixified) Safefree(unixified);
8187     return NULL;
8188   }
8189   PerlMem_free(pathified);
8190   if (buf) {
8191     return buf;
8192   }
8193   else if (ts) {
8194     unixlen = strlen(unixified);
8195     Newx(cp,unixlen+1,char);
8196     memcpy(cp,unixified,unixlen);
8197     cp[unixlen] = '\0';
8198     Safefree(unixified);
8199     return cp;
8200   }
8201   else {
8202     strcpy(__tounixpath_retbuf,unixified);
8203     Safefree(unixified);
8204     return __tounixpath_retbuf;
8205   }
8206
8207 }  /* end of do_tounixpath() */
8208 /*}}}*/
8209 /* External entry points */
8210 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8211   { return do_tounixpath(path,buf,0,NULL); }
8212 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8213   { return do_tounixpath(path,buf,1,NULL); }
8214 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8215   { return do_tounixpath(path,buf,0,utf8_fl); }
8216 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8217   { return do_tounixpath(path,buf,1,utf8_fl); }
8218
8219 /*
8220  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8221  *
8222  *****************************************************************************
8223  *                                                                           *
8224  *  Copyright (C) 1989-1994, 2007 by                                         *
8225  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8226  *                                                                           *
8227  *  Permission is hereby granted for the reproduction of this software       *
8228  *  on condition that this copyright notice is included in source            *
8229  *  distributions of the software.  The code may be modified and             *
8230  *  distributed under the same terms as Perl itself.                         *
8231  *                                                                           *
8232  *  27-Aug-1994 Modified for inclusion in perl5                              *
8233  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8234  *****************************************************************************
8235  */
8236
8237 /*
8238  * getredirection() is intended to aid in porting C programs
8239  * to VMS (Vax-11 C).  The native VMS environment does not support
8240  * '>' and '<' I/O redirection, or command line wild card expansion,
8241  * or a command line pipe mechanism using the '|' AND background
8242  * command execution '&'.  All of these capabilities are provided to any
8243  * C program which calls this procedure as the first thing in the
8244  * main program.
8245  * The piping mechanism will probably work with almost any 'filter' type
8246  * of program.  With suitable modification, it may useful for other
8247  * portability problems as well.
8248  *
8249  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8250  */
8251 struct list_item
8252     {
8253     struct list_item *next;
8254     char *value;
8255     };
8256
8257 static void add_item(struct list_item **head,
8258                      struct list_item **tail,
8259                      char *value,
8260                      int *count);
8261
8262 static void mp_expand_wild_cards(pTHX_ char *item,
8263                                 struct list_item **head,
8264                                 struct list_item **tail,
8265                                 int *count);
8266
8267 static int background_process(pTHX_ int argc, char **argv);
8268
8269 static void pipe_and_fork(pTHX_ char **cmargv);
8270
8271 /*{{{ void getredirection(int *ac, char ***av)*/
8272 static void
8273 mp_getredirection(pTHX_ int *ac, char ***av)
8274 /*
8275  * Process vms redirection arg's.  Exit if any error is seen.
8276  * If getredirection() processes an argument, it is erased
8277  * from the vector.  getredirection() returns a new argc and argv value.
8278  * In the event that a background command is requested (by a trailing "&"),
8279  * this routine creates a background subprocess, and simply exits the program.
8280  *
8281  * Warning: do not try to simplify the code for vms.  The code
8282  * presupposes that getredirection() is called before any data is
8283  * read from stdin or written to stdout.
8284  *
8285  * Normal usage is as follows:
8286  *
8287  *      main(argc, argv)
8288  *      int             argc;
8289  *      char            *argv[];
8290  *      {
8291  *              getredirection(&argc, &argv);
8292  *      }
8293  */
8294 {
8295     int                 argc = *ac;     /* Argument Count         */
8296     char                **argv = *av;   /* Argument Vector        */
8297     char                *ap;            /* Argument pointer       */
8298     int                 j;              /* argv[] index           */
8299     int                 item_count = 0; /* Count of Items in List */
8300     struct list_item    *list_head = 0; /* First Item in List       */
8301     struct list_item    *list_tail;     /* Last Item in List        */
8302     char                *in = NULL;     /* Input File Name          */
8303     char                *out = NULL;    /* Output File Name         */
8304     char                *outmode = "w"; /* Mode to Open Output File */
8305     char                *err = NULL;    /* Error File Name          */
8306     char                *errmode = "w"; /* Mode to Open Error File  */
8307     int                 cmargc = 0;     /* Piped Command Arg Count  */
8308     char                **cmargv = NULL;/* Piped Command Arg Vector */
8309
8310     /*
8311      * First handle the case where the last thing on the line ends with
8312      * a '&'.  This indicates the desire for the command to be run in a
8313      * subprocess, so we satisfy that desire.
8314      */
8315     ap = argv[argc-1];
8316     if (0 == strcmp("&", ap))
8317        exit(background_process(aTHX_ --argc, argv));
8318     if (*ap && '&' == ap[strlen(ap)-1])
8319         {
8320         ap[strlen(ap)-1] = '\0';
8321        exit(background_process(aTHX_ argc, argv));
8322         }
8323     /*
8324      * Now we handle the general redirection cases that involve '>', '>>',
8325      * '<', and pipes '|'.
8326      */
8327     for (j = 0; j < argc; ++j)
8328         {
8329         if (0 == strcmp("<", argv[j]))
8330             {
8331             if (j+1 >= argc)
8332                 {
8333                 fprintf(stderr,"No input file after < on command line");
8334                 exit(LIB$_WRONUMARG);
8335                 }
8336             in = argv[++j];
8337             continue;
8338             }
8339         if ('<' == *(ap = argv[j]))
8340             {
8341             in = 1 + ap;
8342             continue;
8343             }
8344         if (0 == strcmp(">", ap))
8345             {
8346             if (j+1 >= argc)
8347                 {
8348                 fprintf(stderr,"No output file after > on command line");
8349                 exit(LIB$_WRONUMARG);
8350                 }
8351             out = argv[++j];
8352             continue;
8353             }
8354         if ('>' == *ap)
8355             {
8356             if ('>' == ap[1])
8357                 {
8358                 outmode = "a";
8359                 if ('\0' == ap[2])
8360                     out = argv[++j];
8361                 else
8362                     out = 2 + ap;
8363                 }
8364             else
8365                 out = 1 + ap;
8366             if (j >= argc)
8367                 {
8368                 fprintf(stderr,"No output file after > or >> on command line");
8369                 exit(LIB$_WRONUMARG);
8370                 }
8371             continue;
8372             }
8373         if (('2' == *ap) && ('>' == ap[1]))
8374             {
8375             if ('>' == ap[2])
8376                 {
8377                 errmode = "a";
8378                 if ('\0' == ap[3])
8379                     err = argv[++j];
8380                 else
8381                     err = 3 + ap;
8382                 }
8383             else
8384                 if ('\0' == ap[2])
8385                     err = argv[++j];
8386                 else
8387                     err = 2 + ap;
8388             if (j >= argc)
8389                 {
8390                 fprintf(stderr,"No output file after 2> or 2>> on command line");
8391                 exit(LIB$_WRONUMARG);
8392                 }
8393             continue;
8394             }
8395         if (0 == strcmp("|", argv[j]))
8396             {
8397             if (j+1 >= argc)
8398                 {
8399                 fprintf(stderr,"No command into which to pipe on command line");
8400                 exit(LIB$_WRONUMARG);
8401                 }
8402             cmargc = argc-(j+1);
8403             cmargv = &argv[j+1];
8404             argc = j;
8405             continue;
8406             }
8407         if ('|' == *(ap = argv[j]))
8408             {
8409             ++argv[j];
8410             cmargc = argc-j;
8411             cmargv = &argv[j];
8412             argc = j;
8413             continue;
8414             }
8415         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8416         }
8417     /*
8418      * Allocate and fill in the new argument vector, Some Unix's terminate
8419      * the list with an extra null pointer.
8420      */
8421     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8422     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8423     *av = argv;
8424     for (j = 0; j < item_count; ++j, list_head = list_head->next)
8425         argv[j] = list_head->value;
8426     *ac = item_count;
8427     if (cmargv != NULL)
8428         {
8429         if (out != NULL)
8430             {
8431             fprintf(stderr,"'|' and '>' may not both be specified on command line");
8432             exit(LIB$_INVARGORD);
8433             }
8434         pipe_and_fork(aTHX_ cmargv);
8435         }
8436
8437     /* Check for input from a pipe (mailbox) */
8438
8439     if (in == NULL && 1 == isapipe(0))
8440         {
8441         char mbxname[L_tmpnam];
8442         long int bufsize;
8443         long int dvi_item = DVI$_DEVBUFSIZ;
8444         $DESCRIPTOR(mbxnam, "");
8445         $DESCRIPTOR(mbxdevnam, "");
8446
8447         /* Input from a pipe, reopen it in binary mode to disable       */
8448         /* carriage control processing.                                 */
8449
8450         fgetname(stdin, mbxname);
8451         mbxnam.dsc$a_pointer = mbxname;
8452         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8453         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8454         mbxdevnam.dsc$a_pointer = mbxname;
8455         mbxdevnam.dsc$w_length = sizeof(mbxname);
8456         dvi_item = DVI$_DEVNAM;
8457         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8458         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8459         set_errno(0);
8460         set_vaxc_errno(1);
8461         freopen(mbxname, "rb", stdin);
8462         if (errno != 0)
8463             {
8464             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8465             exit(vaxc$errno);
8466             }
8467         }
8468     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8469         {
8470         fprintf(stderr,"Can't open input file %s as stdin",in);
8471         exit(vaxc$errno);
8472         }
8473     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8474         {
8475         fprintf(stderr,"Can't open output file %s as stdout",out);
8476         exit(vaxc$errno);
8477         }
8478         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8479
8480     if (err != NULL) {
8481         if (strcmp(err,"&1") == 0) {
8482             dup2(fileno(stdout), fileno(stderr));
8483             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8484         } else {
8485         FILE *tmperr;
8486         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8487             {
8488             fprintf(stderr,"Can't open error file %s as stderr",err);
8489             exit(vaxc$errno);
8490             }
8491             fclose(tmperr);
8492            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8493                 {
8494                 exit(vaxc$errno);
8495                 }
8496             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8497         }
8498         }
8499 #ifdef ARGPROC_DEBUG
8500     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8501     for (j = 0; j < *ac;  ++j)
8502         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8503 #endif
8504    /* Clear errors we may have hit expanding wildcards, so they don't
8505       show up in Perl's $! later */
8506    set_errno(0); set_vaxc_errno(1);
8507 }  /* end of getredirection() */
8508 /*}}}*/
8509
8510 static void add_item(struct list_item **head,
8511                      struct list_item **tail,
8512                      char *value,
8513                      int *count)
8514 {
8515     if (*head == 0)
8516         {
8517         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8518         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8519         *tail = *head;
8520         }
8521     else {
8522         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8523         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8524         *tail = (*tail)->next;
8525         }
8526     (*tail)->value = value;
8527     ++(*count);
8528 }
8529
8530 static void mp_expand_wild_cards(pTHX_ char *item,
8531                               struct list_item **head,
8532                               struct list_item **tail,
8533                               int *count)
8534 {
8535 int expcount = 0;
8536 unsigned long int context = 0;
8537 int isunix = 0;
8538 int item_len = 0;
8539 char *had_version;
8540 char *had_device;
8541 int had_directory;
8542 char *devdir,*cp;
8543 char *vmsspec;
8544 $DESCRIPTOR(filespec, "");
8545 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8546 $DESCRIPTOR(resultspec, "");
8547 unsigned long int lff_flags = 0;
8548 int sts;
8549 int rms_sts;
8550
8551 #ifdef VMS_LONGNAME_SUPPORT
8552     lff_flags = LIB$M_FIL_LONG_NAMES;
8553 #endif
8554
8555     for (cp = item; *cp; cp++) {
8556         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8557         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8558     }
8559     if (!*cp || isspace(*cp))
8560         {
8561         add_item(head, tail, item, count);
8562         return;
8563         }
8564     else
8565         {
8566      /* "double quoted" wild card expressions pass as is */
8567      /* From DCL that means using e.g.:                  */
8568      /* perl program """perl.*"""                        */
8569      item_len = strlen(item);
8570      if ( '"' == *item && '"' == item[item_len-1] )
8571        {
8572        item++;
8573        item[item_len-2] = '\0';
8574        add_item(head, tail, item, count);
8575        return;
8576        }
8577      }
8578     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8579     resultspec.dsc$b_class = DSC$K_CLASS_D;
8580     resultspec.dsc$a_pointer = NULL;
8581     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8582     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8583     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8584       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8585     if (!isunix || !filespec.dsc$a_pointer)
8586       filespec.dsc$a_pointer = item;
8587     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8588     /*
8589      * Only return version specs, if the caller specified a version
8590      */
8591     had_version = strchr(item, ';');
8592     /*
8593      * Only return device and directory specs, if the caller specifed either.
8594      */
8595     had_device = strchr(item, ':');
8596     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8597
8598     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8599                                  (&filespec, &resultspec, &context,
8600                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8601         {
8602         char *string;
8603         char *c;
8604
8605         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8606         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8607         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8608         string[resultspec.dsc$w_length] = '\0';
8609         if (NULL == had_version)
8610             *(strrchr(string, ';')) = '\0';
8611         if ((!had_directory) && (had_device == NULL))
8612             {
8613             if (NULL == (devdir = strrchr(string, ']')))
8614                 devdir = strrchr(string, '>');
8615             strcpy(string, devdir + 1);
8616             }
8617         /*
8618          * Be consistent with what the C RTL has already done to the rest of
8619          * the argv items and lowercase all of these names.
8620          */
8621         if (!decc_efs_case_preserve) {
8622             for (c = string; *c; ++c)
8623             if (isupper(*c))
8624                 *c = tolower(*c);
8625         }
8626         if (isunix) trim_unixpath(string,item,1);
8627         add_item(head, tail, string, count);
8628         ++expcount;
8629     }
8630     PerlMem_free(vmsspec);
8631     if (sts != RMS$_NMF)
8632         {
8633         set_vaxc_errno(sts);
8634         switch (sts)
8635             {
8636             case RMS$_FNF: case RMS$_DNF:
8637                 set_errno(ENOENT); break;
8638             case RMS$_DIR:
8639                 set_errno(ENOTDIR); break;
8640             case RMS$_DEV:
8641                 set_errno(ENODEV); break;
8642             case RMS$_FNM: case RMS$_SYN:
8643                 set_errno(EINVAL); break;
8644             case RMS$_PRV:
8645                 set_errno(EACCES); break;
8646             default:
8647                 _ckvmssts_noperl(sts);
8648             }
8649         }
8650     if (expcount == 0)
8651         add_item(head, tail, item, count);
8652     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8653     _ckvmssts_noperl(lib$find_file_end(&context));
8654 }
8655
8656 static int child_st[2];/* Event Flag set when child process completes   */
8657
8658 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8659
8660 static unsigned long int exit_handler(int *status)
8661 {
8662 short iosb[4];
8663
8664     if (0 == child_st[0])
8665         {
8666 #ifdef ARGPROC_DEBUG
8667         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8668 #endif
8669         fflush(stdout);     /* Have to flush pipe for binary data to    */
8670                             /* terminate properly -- <tp@mccall.com>    */
8671         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8672         sys$dassgn(child_chan);
8673         fclose(stdout);
8674         sys$synch(0, child_st);
8675         }
8676     return(1);
8677 }
8678
8679 static void sig_child(int chan)
8680 {
8681 #ifdef ARGPROC_DEBUG
8682     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8683 #endif
8684     if (child_st[0] == 0)
8685         child_st[0] = 1;
8686 }
8687
8688 static struct exit_control_block exit_block =
8689     {
8690     0,
8691     exit_handler,
8692     1,
8693     &exit_block.exit_status,
8694     0
8695     };
8696
8697 static void
8698 pipe_and_fork(pTHX_ char **cmargv)
8699 {
8700     PerlIO *fp;
8701     struct dsc$descriptor_s *vmscmd;
8702     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8703     int sts, j, l, ismcr, quote, tquote = 0;
8704
8705     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8706     vms_execfree(vmscmd);
8707
8708     j = l = 0;
8709     p = subcmd;
8710     q = cmargv[0];
8711     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8712               && toupper(*(q+2)) == 'R' && !*(q+3);
8713
8714     while (q && l < MAX_DCL_LINE_LENGTH) {
8715         if (!*q) {
8716             if (j > 0 && quote) {
8717                 *p++ = '"';
8718                 l++;
8719             }
8720             q = cmargv[++j];
8721             if (q) {
8722                 if (ismcr && j > 1) quote = 1;
8723                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8724                 *p++ = ' ';
8725                 l++;
8726                 if (quote || tquote) {
8727                     *p++ = '"';
8728                     l++;
8729                 }
8730             }
8731         } else {
8732             if ((quote||tquote) && *q == '"') {
8733                 *p++ = '"';
8734                 l++;
8735             }
8736             *p++ = *q++;
8737             l++;
8738         }
8739     }
8740     *p = '\0';
8741
8742     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8743     if (fp == Nullfp) {
8744         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8745     }
8746 }
8747
8748 static int background_process(pTHX_ int argc, char **argv)
8749 {
8750 char command[MAX_DCL_SYMBOL + 1] = "$";
8751 $DESCRIPTOR(value, "");
8752 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8753 static $DESCRIPTOR(null, "NLA0:");
8754 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8755 char pidstring[80];
8756 $DESCRIPTOR(pidstr, "");
8757 int pid;
8758 unsigned long int flags = 17, one = 1, retsts;
8759 int len;
8760
8761     strcat(command, argv[0]);
8762     len = strlen(command);
8763     while (--argc && (len < MAX_DCL_SYMBOL))
8764         {
8765         strcat(command, " \"");
8766         strcat(command, *(++argv));
8767         strcat(command, "\"");
8768         len = strlen(command);
8769         }
8770     value.dsc$a_pointer = command;
8771     value.dsc$w_length = strlen(value.dsc$a_pointer);
8772     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8773     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8774     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8775         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8776     }
8777     else {
8778         _ckvmssts_noperl(retsts);
8779     }
8780 #ifdef ARGPROC_DEBUG
8781     PerlIO_printf(Perl_debug_log, "%s\n", command);
8782 #endif
8783     sprintf(pidstring, "%08X", pid);
8784     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8785     pidstr.dsc$a_pointer = pidstring;
8786     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8787     lib$set_symbol(&pidsymbol, &pidstr);
8788     return(SS$_NORMAL);
8789 }
8790 /*}}}*/
8791 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8792
8793
8794 /* OS-specific initialization at image activation (not thread startup) */
8795 /* Older VAXC header files lack these constants */
8796 #ifndef JPI$_RIGHTS_SIZE
8797 #  define JPI$_RIGHTS_SIZE 817
8798 #endif
8799 #ifndef KGB$M_SUBSYSTEM
8800 #  define KGB$M_SUBSYSTEM 0x8
8801 #endif
8802
8803 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8804
8805 /*{{{void vms_image_init(int *, char ***)*/
8806 void
8807 vms_image_init(int *argcp, char ***argvp)
8808 {
8809   char eqv[LNM$C_NAMLENGTH+1] = "";
8810   unsigned int len, tabct = 8, tabidx = 0;
8811   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8812   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8813   unsigned short int dummy, rlen;
8814   struct dsc$descriptor_s **tabvec;
8815 #if defined(PERL_IMPLICIT_CONTEXT)
8816   pTHX = NULL;
8817 #endif
8818   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8819                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8820                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8821                                  {          0,                0,    0,      0} };
8822
8823 #ifdef KILL_BY_SIGPRC
8824     Perl_csighandler_init();
8825 #endif
8826
8827   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8828   _ckvmssts_noperl(iosb[0]);
8829   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8830     if (iprv[i]) {           /* Running image installed with privs? */
8831       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8832       will_taint = TRUE;
8833       break;
8834     }
8835   }
8836   /* Rights identifiers might trigger tainting as well. */
8837   if (!will_taint && (rlen || rsz)) {
8838     while (rlen < rsz) {
8839       /* We didn't get all the identifiers on the first pass.  Allocate a
8840        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8841        * were needed to hold all identifiers at time of last call; we'll
8842        * allocate that many unsigned long ints), and go back and get 'em.
8843        * If it gave us less than it wanted to despite ample buffer space,
8844        * something's broken.  Is your system missing a system identifier?
8845        */
8846       if (rsz <= jpilist[1].buflen) {
8847          /* Perl_croak accvios when used this early in startup. */
8848          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8849                          rsz, (unsigned long) jpilist[1].buflen,
8850                          "Check your rights database for corruption.\n");
8851          exit(SS$_ABORT);
8852       }
8853       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8854       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8855       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8856       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8857       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8858       _ckvmssts_noperl(iosb[0]);
8859     }
8860     mask = jpilist[1].bufadr;
8861     /* Check attribute flags for each identifier (2nd longword); protected
8862      * subsystem identifiers trigger tainting.
8863      */
8864     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8865       if (mask[i] & KGB$M_SUBSYSTEM) {
8866         will_taint = TRUE;
8867         break;
8868       }
8869     }
8870     if (mask != rlst) PerlMem_free(mask);
8871   }
8872
8873   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8874    * logical, some versions of the CRTL will add a phanthom /000000/
8875    * directory.  This needs to be removed.
8876    */
8877   if (decc_filename_unix_report) {
8878   char * zeros;
8879   int ulen;
8880     ulen = strlen(argvp[0][0]);
8881     if (ulen > 7) {
8882       zeros = strstr(argvp[0][0], "/000000/");
8883       if (zeros != NULL) {
8884         int mlen;
8885         mlen = ulen - (zeros - argvp[0][0]) - 7;
8886         memmove(zeros, &zeros[7], mlen);
8887         ulen = ulen - 7;
8888         argvp[0][0][ulen] = '\0';
8889       }
8890     }
8891     /* It also may have a trailing dot that needs to be removed otherwise
8892      * it will be converted to VMS mode incorrectly.
8893      */
8894     ulen--;
8895     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8896       argvp[0][0][ulen] = '\0';
8897   }
8898
8899   /* We need to use this hack to tell Perl it should run with tainting,
8900    * since its tainting flag may be part of the PL_curinterp struct, which
8901    * hasn't been allocated when vms_image_init() is called.
8902    */
8903   if (will_taint) {
8904     char **newargv, **oldargv;
8905     oldargv = *argvp;
8906     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8907     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8908     newargv[0] = oldargv[0];
8909     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8910     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8911     strcpy(newargv[1], "-T");
8912     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8913     (*argcp)++;
8914     newargv[*argcp] = NULL;
8915     /* We orphan the old argv, since we don't know where it's come from,
8916      * so we don't know how to free it.
8917      */
8918     *argvp = newargv;
8919   }
8920   else {  /* Did user explicitly request tainting? */
8921     int i;
8922     char *cp, **av = *argvp;
8923     for (i = 1; i < *argcp; i++) {
8924       if (*av[i] != '-') break;
8925       for (cp = av[i]+1; *cp; cp++) {
8926         if (*cp == 'T') { will_taint = 1; break; }
8927         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8928                   strchr("DFIiMmx",*cp)) break;
8929       }
8930       if (will_taint) break;
8931     }
8932   }
8933
8934   for (tabidx = 0;
8935        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8936        tabidx++) {
8937     if (!tabidx) {
8938       tabvec = (struct dsc$descriptor_s **)
8939             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8940       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8941     }
8942     else if (tabidx >= tabct) {
8943       tabct += 8;
8944       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8945       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8946     }
8947     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8948     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8949     tabvec[tabidx]->dsc$w_length  = 0;
8950     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8951     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8952     tabvec[tabidx]->dsc$a_pointer = NULL;
8953     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8954   }
8955   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8956
8957   getredirection(argcp,argvp);
8958 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8959   {
8960 # include <reentrancy.h>
8961   decc$set_reentrancy(C$C_MULTITHREAD);
8962   }
8963 #endif
8964   return;
8965 }
8966 /*}}}*/
8967
8968
8969 /* trim_unixpath()
8970  * Trim Unix-style prefix off filespec, so it looks like what a shell
8971  * glob expansion would return (i.e. from specified prefix on, not
8972  * full path).  Note that returned filespec is Unix-style, regardless
8973  * of whether input filespec was VMS-style or Unix-style.
8974  *
8975  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8976  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8977  * vector of options; at present, only bit 0 is used, and if set tells
8978  * trim unixpath to try the current default directory as a prefix when
8979  * presented with a possibly ambiguous ... wildcard.
8980  *
8981  * Returns !=0 on success, with trimmed filespec replacing contents of
8982  * fspec, and 0 on failure, with contents of fpsec unchanged.
8983  */
8984 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8985 int
8986 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8987 {
8988   char *unixified, *unixwild,
8989        *template, *base, *end, *cp1, *cp2;
8990   register int tmplen, reslen = 0, dirs = 0;
8991
8992   unixwild = PerlMem_malloc(VMS_MAXRSS);
8993   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8994   if (!wildspec || !fspec) return 0;
8995   template = unixwild;
8996   if (strpbrk(wildspec,"]>:") != NULL) {
8997     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8998         PerlMem_free(unixwild);
8999         return 0;
9000     }
9001   }
9002   else {
9003     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9004     unixwild[VMS_MAXRSS-1] = 0;
9005   }
9006   unixified = PerlMem_malloc(VMS_MAXRSS);
9007   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
9008   if (strpbrk(fspec,"]>:") != NULL) {
9009     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9010         PerlMem_free(unixwild);
9011         PerlMem_free(unixified);
9012         return 0;
9013     }
9014     else base = unixified;
9015     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9016      * check to see that final result fits into (isn't longer than) fspec */
9017     reslen = strlen(fspec);
9018   }
9019   else base = fspec;
9020
9021   /* No prefix or absolute path on wildcard, so nothing to remove */
9022   if (!*template || *template == '/') {
9023     PerlMem_free(unixwild);
9024     if (base == fspec) {
9025         PerlMem_free(unixified);
9026         return 1;
9027     }
9028     tmplen = strlen(unixified);
9029     if (tmplen > reslen) {
9030         PerlMem_free(unixified);
9031         return 0;  /* not enough space */
9032     }
9033     /* Copy unixified resultant, including trailing NUL */
9034     memmove(fspec,unixified,tmplen+1);
9035     PerlMem_free(unixified);
9036     return 1;
9037   }
9038
9039   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9040   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9041     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9042     for (cp1 = end ;cp1 >= base; cp1--)
9043       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9044         { cp1++; break; }
9045     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9046     PerlMem_free(unixified);
9047     PerlMem_free(unixwild);
9048     return 1;
9049   }
9050   else {
9051     char *tpl, *lcres;
9052     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9053     int ells = 1, totells, segdirs, match;
9054     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9055                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9056
9057     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9058     totells = ells;
9059     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9060     tpl = PerlMem_malloc(VMS_MAXRSS);
9061     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
9062     if (ellipsis == template && opts & 1) {
9063       /* Template begins with an ellipsis.  Since we can't tell how many
9064        * directory names at the front of the resultant to keep for an
9065        * arbitrary starting point, we arbitrarily choose the current
9066        * default directory as a starting point.  If it's there as a prefix,
9067        * clip it off.  If not, fall through and act as if the leading
9068        * ellipsis weren't there (i.e. return shortest possible path that
9069        * could match template).
9070        */
9071       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9072           PerlMem_free(tpl);
9073           PerlMem_free(unixified);
9074           PerlMem_free(unixwild);
9075           return 0;
9076       }
9077       if (!decc_efs_case_preserve) {
9078         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9079           if (_tolower(*cp1) != _tolower(*cp2)) break;
9080       }
9081       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9082       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9083       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9084         memmove(fspec,cp2+1,end - cp2);
9085         PerlMem_free(tpl);
9086         PerlMem_free(unixified);
9087         PerlMem_free(unixwild);
9088         return 1;
9089       }
9090     }
9091     /* First off, back up over constant elements at end of path */
9092     if (dirs) {
9093       for (front = end ; front >= base; front--)
9094          if (*front == '/' && !dirs--) { front++; break; }
9095     }
9096     lcres = PerlMem_malloc(VMS_MAXRSS);
9097     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
9098     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9099          cp1++,cp2++) {
9100             if (!decc_efs_case_preserve) {
9101                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9102             }
9103             else {
9104                 *cp2 = *cp1;
9105             }
9106     }
9107     if (cp1 != '\0') {
9108         PerlMem_free(tpl);
9109         PerlMem_free(unixified);
9110         PerlMem_free(unixwild);
9111         PerlMem_free(lcres);
9112         return 0;  /* Path too long. */
9113     }
9114     lcend = cp2;
9115     *cp2 = '\0';  /* Pick up with memcpy later */
9116     lcfront = lcres + (front - base);
9117     /* Now skip over each ellipsis and try to match the path in front of it. */
9118     while (ells--) {
9119       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9120         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9121             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9122       if (cp1 < template) break; /* template started with an ellipsis */
9123       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9124         ellipsis = cp1; continue;
9125       }
9126       wilddsc.dsc$a_pointer = tpl;
9127       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9128       nextell = cp1;
9129       for (segdirs = 0, cp2 = tpl;
9130            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9131            cp1++, cp2++) {
9132          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9133          else {
9134             if (!decc_efs_case_preserve) {
9135               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9136             }
9137             else {
9138               *cp2 = *cp1;  /* else preserve case for match */
9139             }
9140          }
9141          if (*cp2 == '/') segdirs++;
9142       }
9143       if (cp1 != ellipsis - 1) {
9144           PerlMem_free(tpl);
9145           PerlMem_free(unixified);
9146           PerlMem_free(unixwild);
9147           PerlMem_free(lcres);
9148           return 0; /* Path too long */
9149       }
9150       /* Back up at least as many dirs as in template before matching */
9151       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9152         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9153       for (match = 0; cp1 > lcres;) {
9154         resdsc.dsc$a_pointer = cp1;
9155         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9156           match++;
9157           if (match == 1) lcfront = cp1;
9158         }
9159         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9160       }
9161       if (!match) {
9162         PerlMem_free(tpl);
9163         PerlMem_free(unixified);
9164         PerlMem_free(unixwild);
9165         PerlMem_free(lcres);
9166         return 0;  /* Can't find prefix ??? */
9167       }
9168       if (match > 1 && opts & 1) {
9169         /* This ... wildcard could cover more than one set of dirs (i.e.
9170          * a set of similar dir names is repeated).  If the template
9171          * contains more than 1 ..., upstream elements could resolve the
9172          * ambiguity, but it's not worth a full backtracking setup here.
9173          * As a quick heuristic, clip off the current default directory
9174          * if it's present to find the trimmed spec, else use the
9175          * shortest string that this ... could cover.
9176          */
9177         char def[NAM$C_MAXRSS+1], *st;
9178
9179         if (getcwd(def, sizeof def,0) == NULL) {
9180             Safefree(unixified);
9181             Safefree(unixwild);
9182             Safefree(lcres);
9183             Safefree(tpl);
9184             return 0;
9185         }
9186         if (!decc_efs_case_preserve) {
9187           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9188             if (_tolower(*cp1) != _tolower(*cp2)) break;
9189         }
9190         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9191         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9192         if (*cp1 == '\0' && *cp2 == '/') {
9193           memmove(fspec,cp2+1,end - cp2);
9194           PerlMem_free(tpl);
9195           PerlMem_free(unixified);
9196           PerlMem_free(unixwild);
9197           PerlMem_free(lcres);
9198           return 1;
9199         }
9200         /* Nope -- stick with lcfront from above and keep going. */
9201       }
9202     }
9203     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9204     PerlMem_free(tpl);
9205     PerlMem_free(unixified);
9206     PerlMem_free(unixwild);
9207     PerlMem_free(lcres);
9208     return 1;
9209     ellipsis = nextell;
9210   }
9211
9212 }  /* end of trim_unixpath() */
9213 /*}}}*/
9214
9215
9216 /*
9217  *  VMS readdir() routines.
9218  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9219  *
9220  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9221  *  Minor modifications to original routines.
9222  */
9223
9224 /* readdir may have been redefined by reentr.h, so make sure we get
9225  * the local version for what we do here.
9226  */
9227 #ifdef readdir
9228 # undef readdir
9229 #endif
9230 #if !defined(PERL_IMPLICIT_CONTEXT)
9231 # define readdir Perl_readdir
9232 #else
9233 # define readdir(a) Perl_readdir(aTHX_ a)
9234 #endif
9235
9236     /* Number of elements in vms_versions array */
9237 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9238
9239 /*
9240  *  Open a directory, return a handle for later use.
9241  */
9242 /*{{{ DIR *opendir(char*name) */
9243 DIR *
9244 Perl_opendir(pTHX_ const char *name)
9245 {
9246     DIR *dd;
9247     char *dir;
9248     Stat_t sb;
9249
9250     Newx(dir, VMS_MAXRSS, char);
9251     if (do_tovmspath(name,dir,0,NULL) == NULL) {
9252       Safefree(dir);
9253       return NULL;
9254     }
9255     /* Check access before stat; otherwise stat does not
9256      * accurately report whether it's a directory.
9257      */
9258     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9259       /* cando_by_name has already set errno */
9260       Safefree(dir);
9261       return NULL;
9262     }
9263     if (flex_stat(dir,&sb) == -1) return NULL;
9264     if (!S_ISDIR(sb.st_mode)) {
9265       Safefree(dir);
9266       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9267       return NULL;
9268     }
9269     /* Get memory for the handle, and the pattern. */
9270     Newx(dd,1,DIR);
9271     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9272
9273     /* Fill in the fields; mainly playing with the descriptor. */
9274     sprintf(dd->pattern, "%s*.*",dir);
9275     Safefree(dir);
9276     dd->context = 0;
9277     dd->count = 0;
9278     dd->flags = 0;
9279     /* By saying we always want the result of readdir() in unix format, we
9280      * are really saying we want all the escapes removed.  Otherwise the caller,
9281      * having no way to know whether it's already in VMS format, might send it
9282      * through tovmsspec again, thus double escaping.
9283      */
9284     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9285     dd->pat.dsc$a_pointer = dd->pattern;
9286     dd->pat.dsc$w_length = strlen(dd->pattern);
9287     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9288     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9289 #if defined(USE_ITHREADS)
9290     Newx(dd->mutex,1,perl_mutex);
9291     MUTEX_INIT( (perl_mutex *) dd->mutex );
9292 #else
9293     dd->mutex = NULL;
9294 #endif
9295
9296     return dd;
9297 }  /* end of opendir() */
9298 /*}}}*/
9299
9300 /*
9301  *  Set the flag to indicate we want versions or not.
9302  */
9303 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9304 void
9305 vmsreaddirversions(DIR *dd, int flag)
9306 {
9307     if (flag)
9308         dd->flags |= PERL_VMSDIR_M_VERSIONS;
9309     else
9310         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9311 }
9312 /*}}}*/
9313
9314 /*
9315  *  Free up an opened directory.
9316  */
9317 /*{{{ void closedir(DIR *dd)*/
9318 void
9319 Perl_closedir(DIR *dd)
9320 {
9321     int sts;
9322
9323     sts = lib$find_file_end(&dd->context);
9324     Safefree(dd->pattern);
9325 #if defined(USE_ITHREADS)
9326     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9327     Safefree(dd->mutex);
9328 #endif
9329     Safefree(dd);
9330 }
9331 /*}}}*/
9332
9333 /*
9334  *  Collect all the version numbers for the current file.
9335  */
9336 static void
9337 collectversions(pTHX_ DIR *dd)
9338 {
9339     struct dsc$descriptor_s     pat;
9340     struct dsc$descriptor_s     res;
9341     struct dirent *e;
9342     char *p, *text, *buff;
9343     int i;
9344     unsigned long context, tmpsts;
9345
9346     /* Convenient shorthand. */
9347     e = &dd->entry;
9348
9349     /* Add the version wildcard, ignoring the "*.*" put on before */
9350     i = strlen(dd->pattern);
9351     Newx(text,i + e->d_namlen + 3,char);
9352     strcpy(text, dd->pattern);
9353     sprintf(&text[i - 3], "%s;*", e->d_name);
9354
9355     /* Set up the pattern descriptor. */
9356     pat.dsc$a_pointer = text;
9357     pat.dsc$w_length = i + e->d_namlen - 1;
9358     pat.dsc$b_dtype = DSC$K_DTYPE_T;
9359     pat.dsc$b_class = DSC$K_CLASS_S;
9360
9361     /* Set up result descriptor. */
9362     Newx(buff, VMS_MAXRSS, char);
9363     res.dsc$a_pointer = buff;
9364     res.dsc$w_length = VMS_MAXRSS - 1;
9365     res.dsc$b_dtype = DSC$K_DTYPE_T;
9366     res.dsc$b_class = DSC$K_CLASS_S;
9367
9368     /* Read files, collecting versions. */
9369     for (context = 0, e->vms_verscount = 0;
9370          e->vms_verscount < VERSIZE(e);
9371          e->vms_verscount++) {
9372         unsigned long rsts;
9373         unsigned long flags = 0;
9374
9375 #ifdef VMS_LONGNAME_SUPPORT
9376         flags = LIB$M_FIL_LONG_NAMES;
9377 #endif
9378         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9379         if (tmpsts == RMS$_NMF || context == 0) break;
9380         _ckvmssts(tmpsts);
9381         buff[VMS_MAXRSS - 1] = '\0';
9382         if ((p = strchr(buff, ';')))
9383             e->vms_versions[e->vms_verscount] = atoi(p + 1);
9384         else
9385             e->vms_versions[e->vms_verscount] = -1;
9386     }
9387
9388     _ckvmssts(lib$find_file_end(&context));
9389     Safefree(text);
9390     Safefree(buff);
9391
9392 }  /* end of collectversions() */
9393
9394 /*
9395  *  Read the next entry from the directory.
9396  */
9397 /*{{{ struct dirent *readdir(DIR *dd)*/
9398 struct dirent *
9399 Perl_readdir(pTHX_ DIR *dd)
9400 {
9401     struct dsc$descriptor_s     res;
9402     char *p, *buff;
9403     unsigned long int tmpsts;
9404     unsigned long rsts;
9405     unsigned long flags = 0;
9406     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9407     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9408
9409     /* Set up result descriptor, and get next file. */
9410     Newx(buff, VMS_MAXRSS, char);
9411     res.dsc$a_pointer = buff;
9412     res.dsc$w_length = VMS_MAXRSS - 1;
9413     res.dsc$b_dtype = DSC$K_DTYPE_T;
9414     res.dsc$b_class = DSC$K_CLASS_S;
9415
9416 #ifdef VMS_LONGNAME_SUPPORT
9417     flags = LIB$M_FIL_LONG_NAMES;
9418 #endif
9419
9420     tmpsts = lib$find_file
9421         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9422     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
9423     if (!(tmpsts & 1)) {
9424       set_vaxc_errno(tmpsts);
9425       switch (tmpsts) {
9426         case RMS$_PRV:
9427           set_errno(EACCES); break;
9428         case RMS$_DEV:
9429           set_errno(ENODEV); break;
9430         case RMS$_DIR:
9431           set_errno(ENOTDIR); break;
9432         case RMS$_FNF: case RMS$_DNF:
9433           set_errno(ENOENT); break;
9434         default:
9435           set_errno(EVMSERR);
9436       }
9437       Safefree(buff);
9438       return NULL;
9439     }
9440     dd->count++;
9441     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9442     if (!decc_efs_case_preserve) {
9443       buff[VMS_MAXRSS - 1] = '\0';
9444       for (p = buff; *p; p++) *p = _tolower(*p);
9445     }
9446     else {
9447       /* we don't want to force to lowercase, just null terminate */
9448       buff[res.dsc$w_length] = '\0';
9449     }
9450     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
9451     *p = '\0';
9452
9453     /* Skip any directory component and just copy the name. */
9454     sts = vms_split_path
9455        (buff,
9456         &v_spec,
9457         &v_len,
9458         &r_spec,
9459         &r_len,
9460         &d_spec,
9461         &d_len,
9462         &n_spec,
9463         &n_len,
9464         &e_spec,
9465         &e_len,
9466         &vs_spec,
9467         &vs_len);
9468
9469     /* Drop NULL extensions on UNIX file specification */
9470     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9471         (e_len == 1) && decc_readdir_dropdotnotype)) {
9472         e_len = 0;
9473         e_spec[0] = '\0';
9474     }
9475
9476     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9477     dd->entry.d_name[n_len + e_len] = '\0';
9478     dd->entry.d_namlen = strlen(dd->entry.d_name);
9479
9480     /* Convert the filename to UNIX format if needed */
9481     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9482
9483         /* Translate the encoded characters. */
9484         /* Fixme: Unicode handling could result in embedded 0 characters */
9485         if (strchr(dd->entry.d_name, '^') != NULL) {
9486             char new_name[256];
9487             char * q;
9488             p = dd->entry.d_name;
9489             q = new_name;
9490             while (*p != 0) {
9491                 int inchars_read, outchars_added;
9492                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9493                 p += inchars_read;
9494                 q += outchars_added;
9495                 /* fix-me */
9496                 /* if outchars_added > 1, then this is a wide file specification */
9497                 /* Wide file specifications need to be passed in Perl */
9498                 /* counted strings apparently with a Unicode flag */
9499             }
9500             *q = 0;
9501             strcpy(dd->entry.d_name, new_name);
9502             dd->entry.d_namlen = strlen(dd->entry.d_name);
9503         }
9504     }
9505
9506     dd->entry.vms_verscount = 0;
9507     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9508     Safefree(buff);
9509     return &dd->entry;
9510
9511 }  /* end of readdir() */
9512 /*}}}*/
9513
9514 /*
9515  *  Read the next entry from the directory -- thread-safe version.
9516  */
9517 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9518 int
9519 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9520 {
9521     int retval;
9522
9523     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9524
9525     entry = readdir(dd);
9526     *result = entry;
9527     retval = ( *result == NULL ? errno : 0 );
9528
9529     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9530
9531     return retval;
9532
9533 }  /* end of readdir_r() */
9534 /*}}}*/
9535
9536 /*
9537  *  Return something that can be used in a seekdir later.
9538  */
9539 /*{{{ long telldir(DIR *dd)*/
9540 long
9541 Perl_telldir(DIR *dd)
9542 {
9543     return dd->count;
9544 }
9545 /*}}}*/
9546
9547 /*
9548  *  Return to a spot where we used to be.  Brute force.
9549  */
9550 /*{{{ void seekdir(DIR *dd,long count)*/
9551 void
9552 Perl_seekdir(pTHX_ DIR *dd, long count)
9553 {
9554     int old_flags;
9555
9556     /* If we haven't done anything yet... */
9557     if (dd->count == 0)
9558         return;
9559
9560     /* Remember some state, and clear it. */
9561     old_flags = dd->flags;
9562     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9563     _ckvmssts(lib$find_file_end(&dd->context));
9564     dd->context = 0;
9565
9566     /* The increment is in readdir(). */
9567     for (dd->count = 0; dd->count < count; )
9568         readdir(dd);
9569
9570     dd->flags = old_flags;
9571
9572 }  /* end of seekdir() */
9573 /*}}}*/
9574
9575 /* VMS subprocess management
9576  *
9577  * my_vfork() - just a vfork(), after setting a flag to record that
9578  * the current script is trying a Unix-style fork/exec.
9579  *
9580  * vms_do_aexec() and vms_do_exec() are called in response to the
9581  * perl 'exec' function.  If this follows a vfork call, then they
9582  * call out the regular perl routines in doio.c which do an
9583  * execvp (for those who really want to try this under VMS).
9584  * Otherwise, they do exactly what the perl docs say exec should
9585  * do - terminate the current script and invoke a new command
9586  * (See below for notes on command syntax.)
9587  *
9588  * do_aspawn() and do_spawn() implement the VMS side of the perl
9589  * 'system' function.
9590  *
9591  * Note on command arguments to perl 'exec' and 'system': When handled
9592  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9593  * are concatenated to form a DCL command string.  If the first arg
9594  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9595  * the command string is handed off to DCL directly.  Otherwise,
9596  * the first token of the command is taken as the filespec of an image
9597  * to run.  The filespec is expanded using a default type of '.EXE' and
9598  * the process defaults for device, directory, etc., and if found, the resultant
9599  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9600  * the command string as parameters.  This is perhaps a bit complicated,
9601  * but I hope it will form a happy medium between what VMS folks expect
9602  * from lib$spawn and what Unix folks expect from exec.
9603  */
9604
9605 static int vfork_called;
9606
9607 /*{{{int my_vfork()*/
9608 int
9609 my_vfork()
9610 {
9611   vfork_called++;
9612   return vfork();
9613 }
9614 /*}}}*/
9615
9616
9617 static void
9618 vms_execfree(struct dsc$descriptor_s *vmscmd)
9619 {
9620   if (vmscmd) {
9621       if (vmscmd->dsc$a_pointer) {
9622           PerlMem_free(vmscmd->dsc$a_pointer);
9623       }
9624       PerlMem_free(vmscmd);
9625   }
9626 }
9627
9628 static char *
9629 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9630 {
9631   char *junk, *tmps = Nullch;
9632   register size_t cmdlen = 0;
9633   size_t rlen;
9634   register SV **idx;
9635   STRLEN n_a;
9636
9637   idx = mark;
9638   if (really) {
9639     tmps = SvPV(really,rlen);
9640     if (*tmps) {
9641       cmdlen += rlen + 1;
9642       idx++;
9643     }
9644   }
9645
9646   for (idx++; idx <= sp; idx++) {
9647     if (*idx) {
9648       junk = SvPVx(*idx,rlen);
9649       cmdlen += rlen ? rlen + 1 : 0;
9650     }
9651   }
9652   Newx(PL_Cmd, cmdlen+1, char);
9653
9654   if (tmps && *tmps) {
9655     strcpy(PL_Cmd,tmps);
9656     mark++;
9657   }
9658   else *PL_Cmd = '\0';
9659   while (++mark <= sp) {
9660     if (*mark) {
9661       char *s = SvPVx(*mark,n_a);
9662       if (!*s) continue;
9663       if (*PL_Cmd) strcat(PL_Cmd," ");
9664       strcat(PL_Cmd,s);
9665     }
9666   }
9667   return PL_Cmd;
9668
9669 }  /* end of setup_argstr() */
9670
9671
9672 static unsigned long int
9673 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9674                    struct dsc$descriptor_s **pvmscmd)
9675 {
9676   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9677   char image_name[NAM$C_MAXRSS+1];
9678   char image_argv[NAM$C_MAXRSS+1];
9679   $DESCRIPTOR(defdsc,".EXE");
9680   $DESCRIPTOR(defdsc2,".");
9681   $DESCRIPTOR(resdsc,resspec);
9682   struct dsc$descriptor_s *vmscmd;
9683   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9684   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9685   register char *s, *rest, *cp, *wordbreak;
9686   char * cmd;
9687   int cmdlen;
9688   register int isdcl;
9689
9690   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9691   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9692
9693   /* Make a copy for modification */
9694   cmdlen = strlen(incmd);
9695   cmd = PerlMem_malloc(cmdlen+1);
9696   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9697   strncpy(cmd, incmd, cmdlen);
9698   cmd[cmdlen] = 0;
9699   image_name[0] = 0;
9700   image_argv[0] = 0;
9701
9702   vmscmd->dsc$a_pointer = NULL;
9703   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9704   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9705   vmscmd->dsc$w_length = 0;
9706   if (pvmscmd) *pvmscmd = vmscmd;
9707
9708   if (suggest_quote) *suggest_quote = 0;
9709
9710   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9711     PerlMem_free(cmd);
9712     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9713   }
9714
9715   s = cmd;
9716
9717   while (*s && isspace(*s)) s++;
9718
9719   if (*s == '@' || *s == '$') {
9720     vmsspec[0] = *s;  rest = s + 1;
9721     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9722   }
9723   else { cp = vmsspec; rest = s; }
9724   if (*rest == '.' || *rest == '/') {
9725     char *cp2;
9726     for (cp2 = resspec;
9727          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9728          rest++, cp2++) *cp2 = *rest;
9729     *cp2 = '\0';
9730     if (do_tovmsspec(resspec,cp,0,NULL)) {
9731       s = vmsspec;
9732       if (*rest) {
9733         for (cp2 = vmsspec + strlen(vmsspec);
9734              *rest && cp2 - vmsspec < sizeof vmsspec;
9735              rest++, cp2++) *cp2 = *rest;
9736         *cp2 = '\0';
9737       }
9738     }
9739   }
9740   /* Intuit whether verb (first word of cmd) is a DCL command:
9741    *   - if first nonspace char is '@', it's a DCL indirection
9742    * otherwise
9743    *   - if verb contains a filespec separator, it's not a DCL command
9744    *   - if it doesn't, caller tells us whether to default to a DCL
9745    *     command, or to a local image unless told it's DCL (by leading '$')
9746    */
9747   if (*s == '@') {
9748       isdcl = 1;
9749       if (suggest_quote) *suggest_quote = 1;
9750   } else {
9751     register char *filespec = strpbrk(s,":<[.;");
9752     rest = wordbreak = strpbrk(s," \"\t/");
9753     if (!wordbreak) wordbreak = s + strlen(s);
9754     if (*s == '$') check_img = 0;
9755     if (filespec && (filespec < wordbreak)) isdcl = 0;
9756     else isdcl = !check_img;
9757   }
9758
9759   if (!isdcl) {
9760     int rsts;
9761     imgdsc.dsc$a_pointer = s;
9762     imgdsc.dsc$w_length = wordbreak - s;
9763     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9764     if (!(retsts&1)) {
9765         _ckvmssts(lib$find_file_end(&cxt));
9766         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9767       if (!(retsts & 1) && *s == '$') {
9768         _ckvmssts(lib$find_file_end(&cxt));
9769         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9770         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9771         if (!(retsts&1)) {
9772           _ckvmssts(lib$find_file_end(&cxt));
9773           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9774         }
9775       }
9776     }
9777     _ckvmssts(lib$find_file_end(&cxt));
9778
9779     if (retsts & 1) {
9780       FILE *fp;
9781       s = resspec;
9782       while (*s && !isspace(*s)) s++;
9783       *s = '\0';
9784
9785       /* check that it's really not DCL with no file extension */
9786       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9787       if (fp) {
9788         char b[256] = {0,0,0,0};
9789         read(fileno(fp), b, 256);
9790         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9791         if (isdcl) {
9792           int shebang_len;
9793
9794           /* Check for script */
9795           shebang_len = 0;
9796           if ((b[0] == '#') && (b[1] == '!'))
9797              shebang_len = 2;
9798 #ifdef ALTERNATE_SHEBANG
9799           else {
9800             shebang_len = strlen(ALTERNATE_SHEBANG);
9801             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9802               char * perlstr;
9803                 perlstr = strstr("perl",b);
9804                 if (perlstr == NULL)
9805                   shebang_len = 0;
9806             }
9807             else
9808               shebang_len = 0;
9809           }
9810 #endif
9811
9812           if (shebang_len > 0) {
9813           int i;
9814           int j;
9815           char tmpspec[NAM$C_MAXRSS + 1];
9816
9817             i = shebang_len;
9818              /* Image is following after white space */
9819             /*--------------------------------------*/
9820             while (isprint(b[i]) && isspace(b[i]))
9821                 i++;
9822
9823             j = 0;
9824             while (isprint(b[i]) && !isspace(b[i])) {
9825                 tmpspec[j++] = b[i++];
9826                 if (j >= NAM$C_MAXRSS)
9827                    break;
9828             }
9829             tmpspec[j] = '\0';
9830
9831              /* There may be some default parameters to the image */
9832             /*---------------------------------------------------*/
9833             j = 0;
9834             while (isprint(b[i])) {
9835                 image_argv[j++] = b[i++];
9836                 if (j >= NAM$C_MAXRSS)
9837                    break;
9838             }
9839             while ((j > 0) && !isprint(image_argv[j-1]))
9840                 j--;
9841             image_argv[j] = 0;
9842
9843             /* It will need to be converted to VMS format and validated */
9844             if (tmpspec[0] != '\0') {
9845               char * iname;
9846
9847                /* Try to find the exact program requested to be run */
9848               /*---------------------------------------------------*/
9849               iname = do_rmsexpand
9850                  (tmpspec, image_name, 0, ".exe",
9851                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9852               if (iname != NULL) {
9853                 if (cando_by_name_int
9854                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9855                   /* MCR prefix needed */
9856                   isdcl = 0;
9857                 }
9858                 else {
9859                    /* Try again with a null type */
9860                   /*----------------------------*/
9861                   iname = do_rmsexpand
9862                     (tmpspec, image_name, 0, ".",
9863                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9864                   if (iname != NULL) {
9865                     if (cando_by_name_int
9866                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9867                       /* MCR prefix needed */
9868                       isdcl = 0;
9869                     }
9870                   }
9871                 }
9872
9873                  /* Did we find the image to run the script? */
9874                 /*------------------------------------------*/
9875                 if (isdcl) {
9876                   char *tchr;
9877
9878                    /* Assume DCL or foreign command exists */
9879                   /*--------------------------------------*/
9880                   tchr = strrchr(tmpspec, '/');
9881                   if (tchr != NULL) {
9882                     tchr++;
9883                   }
9884                   else {
9885                     tchr = tmpspec;
9886                   }
9887                   strcpy(image_name, tchr);
9888                 }
9889               }
9890             }
9891           }
9892         }
9893         fclose(fp);
9894       }
9895       if (check_img && isdcl) return RMS$_FNF;
9896
9897       if (cando_by_name(S_IXUSR,0,resspec)) {
9898         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9899         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9900         if (!isdcl) {
9901             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9902             if (image_name[0] != 0) {
9903                 strcat(vmscmd->dsc$a_pointer, image_name);
9904                 strcat(vmscmd->dsc$a_pointer, " ");
9905             }
9906         } else if (image_name[0] != 0) {
9907             strcpy(vmscmd->dsc$a_pointer, image_name);
9908             strcat(vmscmd->dsc$a_pointer, " ");
9909         } else {
9910             strcpy(vmscmd->dsc$a_pointer,"@");
9911         }
9912         if (suggest_quote) *suggest_quote = 1;
9913
9914         /* If there is an image name, use original command */
9915         if (image_name[0] == 0)
9916             strcat(vmscmd->dsc$a_pointer,resspec);
9917         else {
9918             rest = cmd;
9919             while (*rest && isspace(*rest)) rest++;
9920         }
9921
9922         if (image_argv[0] != 0) {
9923           strcat(vmscmd->dsc$a_pointer,image_argv);
9924           strcat(vmscmd->dsc$a_pointer, " ");
9925         }
9926         if (rest) {
9927            int rest_len;
9928            int vmscmd_len;
9929
9930            rest_len = strlen(rest);
9931            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9932            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9933               strcat(vmscmd->dsc$a_pointer,rest);
9934            else
9935              retsts = CLI$_BUFOVF;
9936         }
9937         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9938         PerlMem_free(cmd);
9939         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9940       }
9941       else
9942         retsts = RMS$_PRV;
9943     }
9944   }
9945   /* It's either a DCL command or we couldn't find a suitable image */
9946   vmscmd->dsc$w_length = strlen(cmd);
9947
9948   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9949   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9950   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9951
9952   PerlMem_free(cmd);
9953
9954   /* check if it's a symbol (for quoting purposes) */
9955   if (suggest_quote && !*suggest_quote) {
9956     int iss;
9957     char equiv[LNM$C_NAMLENGTH];
9958     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9959     eqvdsc.dsc$a_pointer = equiv;
9960
9961     iss = lib$get_symbol(vmscmd,&eqvdsc);
9962     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9963   }
9964   if (!(retsts & 1)) {
9965     /* just hand off status values likely to be due to user error */
9966     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9967         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9968        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9969     else { _ckvmssts(retsts); }
9970   }
9971
9972   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9973
9974 }  /* end of setup_cmddsc() */
9975
9976
9977 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9978 bool
9979 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9980 {
9981 bool exec_sts;
9982 char * cmd;
9983
9984   if (sp > mark) {
9985     if (vfork_called) {           /* this follows a vfork - act Unixish */
9986       vfork_called--;
9987       if (vfork_called < 0) {
9988         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9989         vfork_called = 0;
9990       }
9991       else return do_aexec(really,mark,sp);
9992     }
9993                                            /* no vfork - act VMSish */
9994     cmd = setup_argstr(aTHX_ really,mark,sp);
9995     exec_sts = vms_do_exec(cmd);
9996     Safefree(cmd);  /* Clean up from setup_argstr() */
9997     return exec_sts;
9998   }
9999
10000   return FALSE;
10001 }  /* end of vms_do_aexec() */
10002 /*}}}*/
10003
10004 /* {{{bool vms_do_exec(char *cmd) */
10005 bool
10006 Perl_vms_do_exec(pTHX_ const char *cmd)
10007 {
10008   struct dsc$descriptor_s *vmscmd;
10009
10010   if (vfork_called) {             /* this follows a vfork - act Unixish */
10011     vfork_called--;
10012     if (vfork_called < 0) {
10013       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10014       vfork_called = 0;
10015     }
10016     else return do_exec(cmd);
10017   }
10018
10019   {                               /* no vfork - act VMSish */
10020     unsigned long int retsts;
10021
10022     TAINT_ENV();
10023     TAINT_PROPER("exec");
10024     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10025       retsts = lib$do_command(vmscmd);
10026
10027     switch (retsts) {
10028       case RMS$_FNF: case RMS$_DNF:
10029         set_errno(ENOENT); break;
10030       case RMS$_DIR:
10031         set_errno(ENOTDIR); break;
10032       case RMS$_DEV:
10033         set_errno(ENODEV); break;
10034       case RMS$_PRV:
10035         set_errno(EACCES); break;
10036       case RMS$_SYN:
10037         set_errno(EINVAL); break;
10038       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10039         set_errno(E2BIG); break;
10040       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10041         _ckvmssts(retsts); /* fall through */
10042       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10043         set_errno(EVMSERR);
10044     }
10045     set_vaxc_errno(retsts);
10046     if (ckWARN(WARN_EXEC)) {
10047       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10048              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10049     }
10050     vms_execfree(vmscmd);
10051   }
10052
10053   return FALSE;
10054
10055 }  /* end of vms_do_exec() */
10056 /*}}}*/
10057
10058 unsigned long int Perl_do_spawn(pTHX_ const char *);
10059
10060 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
10061 unsigned long int
10062 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
10063 {
10064 unsigned long int sts;
10065 char * cmd;
10066
10067   if (sp > mark) {
10068     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
10069     sts = do_spawn(cmd);
10070     /* pp_sys will clean up cmd */
10071     return sts;
10072   }
10073   return SS$_ABORT;
10074 }  /* end of do_aspawn() */
10075 /*}}}*/
10076
10077 /* {{{unsigned long int do_spawn(char *cmd) */
10078 unsigned long int
10079 Perl_do_spawn(pTHX_ const char *cmd)
10080 {
10081   unsigned long int sts, substs;
10082
10083   /* The caller of this routine expects to Safefree(PL_Cmd) */
10084   Newx(PL_Cmd,10,char);
10085
10086   TAINT_ENV();
10087   TAINT_PROPER("spawn");
10088   if (!cmd || !*cmd) {
10089     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
10090     if (!(sts & 1)) {
10091       switch (sts) {
10092         case RMS$_FNF:  case RMS$_DNF:
10093           set_errno(ENOENT); break;
10094         case RMS$_DIR:
10095           set_errno(ENOTDIR); break;
10096         case RMS$_DEV:
10097           set_errno(ENODEV); break;
10098         case RMS$_PRV:
10099           set_errno(EACCES); break;
10100         case RMS$_SYN:
10101           set_errno(EINVAL); break;
10102         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10103           set_errno(E2BIG); break;
10104         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10105           _ckvmssts(sts); /* fall through */
10106         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10107           set_errno(EVMSERR);
10108       }
10109       set_vaxc_errno(sts);
10110       if (ckWARN(WARN_EXEC)) {
10111         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10112                     Strerror(errno));
10113       }
10114     }
10115     sts = substs;
10116   }
10117   else {
10118     PerlIO * fp;
10119     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
10120     if (fp != NULL)
10121       my_pclose(fp);
10122   }
10123   return sts;
10124 }  /* end of do_spawn() */
10125 /*}}}*/
10126
10127
10128 static unsigned int *sockflags, sockflagsize;
10129
10130 /*
10131  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10132  * routines found in some versions of the CRTL can't deal with sockets.
10133  * We don't shim the other file open routines since a socket isn't
10134  * likely to be opened by a name.
10135  */
10136 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10137 FILE *my_fdopen(int fd, const char *mode)
10138 {
10139   FILE *fp = fdopen(fd, mode);
10140
10141   if (fp) {
10142     unsigned int fdoff = fd / sizeof(unsigned int);
10143     Stat_t sbuf; /* native stat; we don't need flex_stat */
10144     if (!sockflagsize || fdoff > sockflagsize) {
10145       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10146       else           Newx  (sockflags,fdoff+2,unsigned int);
10147       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10148       sockflagsize = fdoff + 2;
10149     }
10150     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10151       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10152   }
10153   return fp;
10154
10155 }
10156 /*}}}*/
10157
10158
10159 /*
10160  * Clear the corresponding bit when the (possibly) socket stream is closed.
10161  * There still a small hole: we miss an implicit close which might occur
10162  * via freopen().  >> Todo
10163  */
10164 /*{{{ int my_fclose(FILE *fp)*/
10165 int my_fclose(FILE *fp) {
10166   if (fp) {
10167     unsigned int fd = fileno(fp);
10168     unsigned int fdoff = fd / sizeof(unsigned int);
10169
10170     if (sockflagsize && fdoff <= sockflagsize)
10171       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10172   }
10173   return fclose(fp);
10174 }
10175 /*}}}*/
10176
10177
10178 /*
10179  * A simple fwrite replacement which outputs itmsz*nitm chars without
10180  * introducing record boundaries every itmsz chars.
10181  * We are using fputs, which depends on a terminating null.  We may
10182  * well be writing binary data, so we need to accommodate not only
10183  * data with nulls sprinkled in the middle but also data with no null
10184  * byte at the end.
10185  */
10186 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10187 int
10188 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10189 {
10190   register char *cp, *end, *cpd, *data;
10191   register unsigned int fd = fileno(dest);
10192   register unsigned int fdoff = fd / sizeof(unsigned int);
10193   int retval;
10194   int bufsize = itmsz * nitm + 1;
10195
10196   if (fdoff < sockflagsize &&
10197       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10198     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10199     return nitm;
10200   }
10201
10202   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10203   memcpy( data, src, itmsz*nitm );
10204   data[itmsz*nitm] = '\0';
10205
10206   end = data + itmsz * nitm;
10207   retval = (int) nitm; /* on success return # items written */
10208
10209   cpd = data;
10210   while (cpd <= end) {
10211     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10212     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10213     if (cp < end)
10214       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10215     cpd = cp + 1;
10216   }
10217
10218   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10219   return retval;
10220
10221 }  /* end of my_fwrite() */
10222 /*}}}*/
10223
10224 /*{{{ int my_flush(FILE *fp)*/
10225 int
10226 Perl_my_flush(pTHX_ FILE *fp)
10227 {
10228     int res;
10229     if ((res = fflush(fp)) == 0 && fp) {
10230 #ifdef VMS_DO_SOCKETS
10231         Stat_t s;
10232         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
10233 #endif
10234             res = fsync(fileno(fp));
10235     }
10236 /*
10237  * If the flush succeeded but set end-of-file, we need to clear
10238  * the error because our caller may check ferror().  BTW, this
10239  * probably means we just flushed an empty file.
10240  */
10241     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10242
10243     return res;
10244 }
10245 /*}}}*/
10246
10247 /*
10248  * Here are replacements for the following Unix routines in the VMS environment:
10249  *      getpwuid    Get information for a particular UIC or UID
10250  *      getpwnam    Get information for a named user
10251  *      getpwent    Get information for each user in the rights database
10252  *      setpwent    Reset search to the start of the rights database
10253  *      endpwent    Finish searching for users in the rights database
10254  *
10255  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10256  * (defined in pwd.h), which contains the following fields:-
10257  *      struct passwd {
10258  *              char        *pw_name;    Username (in lower case)
10259  *              char        *pw_passwd;  Hashed password
10260  *              unsigned int pw_uid;     UIC
10261  *              unsigned int pw_gid;     UIC group  number
10262  *              char        *pw_unixdir; Default device/directory (VMS-style)
10263  *              char        *pw_gecos;   Owner name
10264  *              char        *pw_dir;     Default device/directory (Unix-style)
10265  *              char        *pw_shell;   Default CLI name (eg. DCL)
10266  *      };
10267  * If the specified user does not exist, getpwuid and getpwnam return NULL.
10268  *
10269  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10270  * not the UIC member number (eg. what's returned by getuid()),
10271  * getpwuid() can accept either as input (if uid is specified, the caller's
10272  * UIC group is used), though it won't recognise gid=0.
10273  *
10274  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10275  * information about other users in your group or in other groups, respectively.
10276  * If the required privilege is not available, then these routines fill only
10277  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10278  * string).
10279  *
10280  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10281  */
10282
10283 /* sizes of various UAF record fields */
10284 #define UAI$S_USERNAME 12
10285 #define UAI$S_IDENT    31
10286 #define UAI$S_OWNER    31
10287 #define UAI$S_DEFDEV   31
10288 #define UAI$S_DEFDIR   63
10289 #define UAI$S_DEFCLI   31
10290 #define UAI$S_PWD       8
10291
10292 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
10293                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10294                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
10295
10296 static char __empty[]= "";
10297 static struct passwd __passwd_empty=
10298     {(char *) __empty, (char *) __empty, 0, 0,
10299      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10300 static int contxt= 0;
10301 static struct passwd __pwdcache;
10302 static char __pw_namecache[UAI$S_IDENT+1];
10303
10304 /*
10305  * This routine does most of the work extracting the user information.
10306  */
10307 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10308 {
10309     static struct {
10310         unsigned char length;
10311         char pw_gecos[UAI$S_OWNER+1];
10312     } owner;
10313     static union uicdef uic;
10314     static struct {
10315         unsigned char length;
10316         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10317     } defdev;
10318     static struct {
10319         unsigned char length;
10320         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10321     } defdir;
10322     static struct {
10323         unsigned char length;
10324         char pw_shell[UAI$S_DEFCLI+1];
10325     } defcli;
10326     static char pw_passwd[UAI$S_PWD+1];
10327
10328     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10329     struct dsc$descriptor_s name_desc;
10330     unsigned long int sts;
10331
10332     static struct itmlst_3 itmlst[]= {
10333         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
10334         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
10335         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
10336         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
10337         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
10338         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
10339         {0,                0,           NULL,    NULL}};
10340
10341     name_desc.dsc$w_length=  strlen(name);
10342     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10343     name_desc.dsc$b_class=   DSC$K_CLASS_S;
10344     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10345
10346 /*  Note that sys$getuai returns many fields as counted strings. */
10347     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10348     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10349       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10350     }
10351     else { _ckvmssts(sts); }
10352     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
10353
10354     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
10355     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10356     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10357     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10358     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10359     owner.pw_gecos[lowner]=            '\0';
10360     defdev.pw_dir[ldefdev+ldefdir]= '\0';
10361     defcli.pw_shell[ldefcli]=          '\0';
10362     if (valid_uic(uic)) {
10363         pwd->pw_uid= uic.uic$l_uic;
10364         pwd->pw_gid= uic.uic$v_group;
10365     }
10366     else
10367       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10368     pwd->pw_passwd=  pw_passwd;
10369     pwd->pw_gecos=   owner.pw_gecos;
10370     pwd->pw_dir=     defdev.pw_dir;
10371     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10372     pwd->pw_shell=   defcli.pw_shell;
10373     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10374         int ldir;
10375         ldir= strlen(pwd->pw_unixdir) - 1;
10376         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10377     }
10378     else
10379         strcpy(pwd->pw_unixdir, pwd->pw_dir);
10380     if (!decc_efs_case_preserve)
10381         __mystrtolower(pwd->pw_unixdir);
10382     return 1;
10383 }
10384
10385 /*
10386  * Get information for a named user.
10387 */
10388 /*{{{struct passwd *getpwnam(char *name)*/
10389 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10390 {
10391     struct dsc$descriptor_s name_desc;
10392     union uicdef uic;
10393     unsigned long int status, sts;
10394
10395     __pwdcache = __passwd_empty;
10396     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10397       /* We still may be able to determine pw_uid and pw_gid */
10398       name_desc.dsc$w_length=  strlen(name);
10399       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10400       name_desc.dsc$b_class=   DSC$K_CLASS_S;
10401       name_desc.dsc$a_pointer= (char *) name;
10402       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10403         __pwdcache.pw_uid= uic.uic$l_uic;
10404         __pwdcache.pw_gid= uic.uic$v_group;
10405       }
10406       else {
10407         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10408           set_vaxc_errno(sts);
10409           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10410           return NULL;
10411         }
10412         else { _ckvmssts(sts); }
10413       }
10414     }
10415     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10416     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10417     __pwdcache.pw_name= __pw_namecache;
10418     return &__pwdcache;
10419 }  /* end of my_getpwnam() */
10420 /*}}}*/
10421
10422 /*
10423  * Get information for a particular UIC or UID.
10424  * Called by my_getpwent with uid=-1 to list all users.
10425 */
10426 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10427 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10428 {
10429     const $DESCRIPTOR(name_desc,__pw_namecache);
10430     unsigned short lname;
10431     union uicdef uic;
10432     unsigned long int status;
10433
10434     if (uid == (unsigned int) -1) {
10435       do {
10436         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10437         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10438           set_vaxc_errno(status);
10439           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10440           my_endpwent();
10441           return NULL;
10442         }
10443         else { _ckvmssts(status); }
10444       } while (!valid_uic (uic));
10445     }
10446     else {
10447       uic.uic$l_uic= uid;
10448       if (!uic.uic$v_group)
10449         uic.uic$v_group= PerlProc_getgid();
10450       if (valid_uic(uic))
10451         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10452       else status = SS$_IVIDENT;
10453       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10454           status == RMS$_PRV) {
10455         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10456         return NULL;
10457       }
10458       else { _ckvmssts(status); }
10459     }
10460     __pw_namecache[lname]= '\0';
10461     __mystrtolower(__pw_namecache);
10462
10463     __pwdcache = __passwd_empty;
10464     __pwdcache.pw_name = __pw_namecache;
10465
10466 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10467     The identifier's value is usually the UIC, but it doesn't have to be,
10468     so if we can, we let fillpasswd update this. */
10469     __pwdcache.pw_uid =  uic.uic$l_uic;
10470     __pwdcache.pw_gid =  uic.uic$v_group;
10471
10472     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10473     return &__pwdcache;
10474
10475 }  /* end of my_getpwuid() */
10476 /*}}}*/
10477
10478 /*
10479  * Get information for next user.
10480 */
10481 /*{{{struct passwd *my_getpwent()*/
10482 struct passwd *Perl_my_getpwent(pTHX)
10483 {
10484     return (my_getpwuid((unsigned int) -1));
10485 }
10486 /*}}}*/
10487
10488 /*
10489  * Finish searching rights database for users.
10490 */
10491 /*{{{void my_endpwent()*/
10492 void Perl_my_endpwent(pTHX)
10493 {
10494     if (contxt) {
10495       _ckvmssts(sys$finish_rdb(&contxt));
10496       contxt= 0;
10497     }
10498 }
10499 /*}}}*/
10500
10501 #ifdef HOMEGROWN_POSIX_SIGNALS
10502   /* Signal handling routines, pulled into the core from POSIX.xs.
10503    *
10504    * We need these for threads, so they've been rolled into the core,
10505    * rather than left in POSIX.xs.
10506    *
10507    * (DRS, Oct 23, 1997)
10508    */
10509
10510   /* sigset_t is atomic under VMS, so these routines are easy */
10511 /*{{{int my_sigemptyset(sigset_t *) */
10512 int my_sigemptyset(sigset_t *set) {
10513     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10514     *set = 0; return 0;
10515 }
10516 /*}}}*/
10517
10518
10519 /*{{{int my_sigfillset(sigset_t *)*/
10520 int my_sigfillset(sigset_t *set) {
10521     int i;
10522     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10523     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10524     return 0;
10525 }
10526 /*}}}*/
10527
10528
10529 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10530 int my_sigaddset(sigset_t *set, int sig) {
10531     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10532     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10533     *set |= (1 << (sig - 1));
10534     return 0;
10535 }
10536 /*}}}*/
10537
10538
10539 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10540 int my_sigdelset(sigset_t *set, int sig) {
10541     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10542     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10543     *set &= ~(1 << (sig - 1));
10544     return 0;
10545 }
10546 /*}}}*/
10547
10548
10549 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10550 int my_sigismember(sigset_t *set, int sig) {
10551     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10552     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10553     return *set & (1 << (sig - 1));
10554 }
10555 /*}}}*/
10556
10557
10558 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10559 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10560     sigset_t tempmask;
10561
10562     /* If set and oset are both null, then things are badly wrong. Bail out. */
10563     if ((oset == NULL) && (set == NULL)) {
10564       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10565       return -1;
10566     }
10567
10568     /* If set's null, then we're just handling a fetch. */
10569     if (set == NULL) {
10570         tempmask = sigblock(0);
10571     }
10572     else {
10573       switch (how) {
10574       case SIG_SETMASK:
10575         tempmask = sigsetmask(*set);
10576         break;
10577       case SIG_BLOCK:
10578         tempmask = sigblock(*set);
10579         break;
10580       case SIG_UNBLOCK:
10581         tempmask = sigblock(0);
10582         sigsetmask(*oset & ~tempmask);
10583         break;
10584       default:
10585         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10586         return -1;
10587       }
10588     }
10589
10590     /* Did they pass us an oset? If so, stick our holding mask into it */
10591     if (oset)
10592       *oset = tempmask;
10593
10594     return 0;
10595 }
10596 /*}}}*/
10597 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10598
10599
10600 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10601  * my_utime(), and flex_stat(), all of which operate on UTC unless
10602  * VMSISH_TIMES is true.
10603  */
10604 /* method used to handle UTC conversions:
10605  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10606  */
10607 static int gmtime_emulation_type;
10608 /* number of secs to add to UTC POSIX-style time to get local time */
10609 static long int utc_offset_secs;
10610
10611 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10612  * in vmsish.h.  #undef them here so we can call the CRTL routines
10613  * directly.
10614  */
10615 #undef gmtime
10616 #undef localtime
10617 #undef time
10618
10619
10620 /*
10621  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10622  * qualifier with the extern prefix pragma.  This provisional
10623  * hack circumvents this prefix pragma problem in previous
10624  * precompilers.
10625  */
10626 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10627 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10628 #    pragma __extern_prefix save
10629 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10630 #    define gmtime decc$__utctz_gmtime
10631 #    define localtime decc$__utctz_localtime
10632 #    define time decc$__utc_time
10633 #    pragma __extern_prefix restore
10634
10635      struct tm *gmtime(), *localtime();
10636
10637 #  endif
10638 #endif
10639
10640
10641 static time_t toutc_dst(time_t loc) {
10642   struct tm *rsltmp;
10643
10644   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10645   loc -= utc_offset_secs;
10646   if (rsltmp->tm_isdst) loc -= 3600;
10647   return loc;
10648 }
10649 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10650        ((gmtime_emulation_type || my_time(NULL)), \
10651        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10652        ((secs) - utc_offset_secs))))
10653
10654 static time_t toloc_dst(time_t utc) {
10655   struct tm *rsltmp;
10656
10657   utc += utc_offset_secs;
10658   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10659   if (rsltmp->tm_isdst) utc += 3600;
10660   return utc;
10661 }
10662 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10663        ((gmtime_emulation_type || my_time(NULL)), \
10664        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10665        ((secs) + utc_offset_secs))))
10666
10667 #ifndef RTL_USES_UTC
10668 /*
10669
10670     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10671         DST starts on 1st sun of april      at 02:00  std time
10672             ends on last sun of october     at 02:00  dst time
10673     see the UCX management command reference, SET CONFIG TIMEZONE
10674     for formatting info.
10675
10676     No, it's not as general as it should be, but then again, NOTHING
10677     will handle UK times in a sensible way.
10678 */
10679
10680
10681 /*
10682     parse the DST start/end info:
10683     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10684 */
10685
10686 static char *
10687 tz_parse_startend(char *s, struct tm *w, int *past)
10688 {
10689     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10690     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10691     time_t g;
10692
10693     if (!s)    return 0;
10694     if (!w) return 0;
10695     if (!past) return 0;
10696
10697     ly = 0;
10698     if (w->tm_year % 4        == 0) ly = 1;
10699     if (w->tm_year % 100      == 0) ly = 0;
10700     if (w->tm_year+1900 % 400 == 0) ly = 1;
10701     if (ly) dinm[1]++;
10702
10703     dozjd = isdigit(*s);
10704     if (*s == 'J' || *s == 'j' || dozjd) {
10705         if (!dozjd && !isdigit(*++s)) return 0;
10706         d = *s++ - '0';
10707         if (isdigit(*s)) {
10708             d = d*10 + *s++ - '0';
10709             if (isdigit(*s)) {
10710                 d = d*10 + *s++ - '0';
10711             }
10712         }
10713         if (d == 0) return 0;
10714         if (d > 366) return 0;
10715         d--;
10716         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10717         g = d * 86400;
10718         dozjd = 1;
10719     } else if (*s == 'M' || *s == 'm') {
10720         if (!isdigit(*++s)) return 0;
10721         m = *s++ - '0';
10722         if (isdigit(*s)) m = 10*m + *s++ - '0';
10723         if (*s != '.') return 0;
10724         if (!isdigit(*++s)) return 0;
10725         n = *s++ - '0';
10726         if (n < 1 || n > 5) return 0;
10727         if (*s != '.') return 0;
10728         if (!isdigit(*++s)) return 0;
10729         d = *s++ - '0';
10730         if (d > 6) return 0;
10731     }
10732
10733     if (*s == '/') {
10734         if (!isdigit(*++s)) return 0;
10735         hour = *s++ - '0';
10736         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10737         if (*s == ':') {
10738             if (!isdigit(*++s)) return 0;
10739             min = *s++ - '0';
10740             if (isdigit(*s)) min = 10*min + *s++ - '0';
10741             if (*s == ':') {
10742                 if (!isdigit(*++s)) return 0;
10743                 sec = *s++ - '0';
10744                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10745             }
10746         }
10747     } else {
10748         hour = 2;
10749         min = 0;
10750         sec = 0;
10751     }
10752
10753     if (dozjd) {
10754         if (w->tm_yday < d) goto before;
10755         if (w->tm_yday > d) goto after;
10756     } else {
10757         if (w->tm_mon+1 < m) goto before;
10758         if (w->tm_mon+1 > m) goto after;
10759
10760         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10761         k = d - j; /* mday of first d */
10762         if (k <= 0) k += 7;
10763         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10764         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10765         if (w->tm_mday < k) goto before;
10766         if (w->tm_mday > k) goto after;
10767     }
10768
10769     if (w->tm_hour < hour) goto before;
10770     if (w->tm_hour > hour) goto after;
10771     if (w->tm_min  < min)  goto before;
10772     if (w->tm_min  > min)  goto after;
10773     if (w->tm_sec  < sec)  goto before;
10774     goto after;
10775
10776 before:
10777     *past = 0;
10778     return s;
10779 after:
10780     *past = 1;
10781     return s;
10782 }
10783
10784
10785
10786
10787 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10788
10789 static char *
10790 tz_parse_offset(char *s, int *offset)
10791 {
10792     int hour = 0, min = 0, sec = 0;
10793     int neg = 0;
10794     if (!s) return 0;
10795     if (!offset) return 0;
10796
10797     if (*s == '-') {neg++; s++;}
10798     if (*s == '+') s++;
10799     if (!isdigit(*s)) return 0;
10800     hour = *s++ - '0';
10801     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10802     if (hour > 24) return 0;
10803     if (*s == ':') {
10804         if (!isdigit(*++s)) return 0;
10805         min = *s++ - '0';
10806         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10807         if (min > 59) return 0;
10808         if (*s == ':') {
10809             if (!isdigit(*++s)) return 0;
10810             sec = *s++ - '0';
10811             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10812             if (sec > 59) return 0;
10813         }
10814     }
10815
10816     *offset = (hour*60+min)*60 + sec;
10817     if (neg) *offset = -*offset;
10818     return s;
10819 }
10820
10821 /*
10822     input time is w, whatever type of time the CRTL localtime() uses.
10823     sets dst, the zone, and the gmtoff (seconds)
10824
10825     caches the value of TZ and UCX$TZ env variables; note that
10826     my_setenv looks for these and sets a flag if they're changed
10827     for efficiency.
10828
10829     We have to watch out for the "australian" case (dst starts in
10830     october, ends in april)...flagged by "reverse" and checked by
10831     scanning through the months of the previous year.
10832
10833 */
10834
10835 static int
10836 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10837 {
10838     time_t when;
10839     struct tm *w2;
10840     char *s,*s2;
10841     char *dstzone, *tz, *s_start, *s_end;
10842     int std_off, dst_off, isdst;
10843     int y, dststart, dstend;
10844     static char envtz[1025];  /* longer than any logical, symbol, ... */
10845     static char ucxtz[1025];
10846     static char reversed = 0;
10847
10848     if (!w) return 0;
10849
10850     if (tz_updated) {
10851         tz_updated = 0;
10852         reversed = -1;  /* flag need to check  */
10853         envtz[0] = ucxtz[0] = '\0';
10854         tz = my_getenv("TZ",0);
10855         if (tz) strcpy(envtz, tz);
10856         tz = my_getenv("UCX$TZ",0);
10857         if (tz) strcpy(ucxtz, tz);
10858         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10859     }
10860     tz = envtz;
10861     if (!*tz) tz = ucxtz;
10862
10863     s = tz;
10864     while (isalpha(*s)) s++;
10865     s = tz_parse_offset(s, &std_off);
10866     if (!s) return 0;
10867     if (!*s) {                  /* no DST, hurray we're done! */
10868         isdst = 0;
10869         goto done;
10870     }
10871
10872     dstzone = s;
10873     while (isalpha(*s)) s++;
10874     s2 = tz_parse_offset(s, &dst_off);
10875     if (s2) {
10876         s = s2;
10877     } else {
10878         dst_off = std_off - 3600;
10879     }
10880
10881     if (!*s) {      /* default dst start/end?? */
10882         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10883             s = strchr(ucxtz,',');
10884         }
10885         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10886     }
10887     if (*s != ',') return 0;
10888
10889     when = *w;
10890     when = _toutc(when);      /* convert to utc */
10891     when = when - std_off;    /* convert to pseudolocal time*/
10892
10893     w2 = localtime(&when);
10894     y = w2->tm_year;
10895     s_start = s+1;
10896     s = tz_parse_startend(s_start,w2,&dststart);
10897     if (!s) return 0;
10898     if (*s != ',') return 0;
10899
10900     when = *w;
10901     when = _toutc(when);      /* convert to utc */
10902     when = when - dst_off;    /* convert to pseudolocal time*/
10903     w2 = localtime(&when);
10904     if (w2->tm_year != y) {   /* spans a year, just check one time */
10905         when += dst_off - std_off;
10906         w2 = localtime(&when);
10907     }
10908     s_end = s+1;
10909     s = tz_parse_startend(s_end,w2,&dstend);
10910     if (!s) return 0;
10911
10912     if (reversed == -1) {  /* need to check if start later than end */
10913         int j, ds, de;
10914
10915         when = *w;
10916         if (when < 2*365*86400) {
10917             when += 2*365*86400;
10918         } else {
10919             when -= 365*86400;
10920         }
10921         w2 =localtime(&when);
10922         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10923
10924         for (j = 0; j < 12; j++) {
10925             w2 =localtime(&when);
10926             tz_parse_startend(s_start,w2,&ds);
10927             tz_parse_startend(s_end,w2,&de);
10928             if (ds != de) break;
10929             when += 30*86400;
10930         }
10931         reversed = 0;
10932         if (de && !ds) reversed = 1;
10933     }
10934
10935     isdst = dststart && !dstend;
10936     if (reversed) isdst = dststart  || !dstend;
10937
10938 done:
10939     if (dst)    *dst = isdst;
10940     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10941     if (isdst)  tz = dstzone;
10942     if (zone) {
10943         while(isalpha(*tz))  *zone++ = *tz++;
10944         *zone = '\0';
10945     }
10946     return 1;
10947 }
10948
10949 #endif /* !RTL_USES_UTC */
10950
10951 /* my_time(), my_localtime(), my_gmtime()
10952  * By default traffic in UTC time values, using CRTL gmtime() or
10953  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10954  * Note: We need to use these functions even when the CRTL has working
10955  * UTC support, since they also handle C<use vmsish qw(times);>
10956  *
10957  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10958  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10959  */
10960
10961 /*{{{time_t my_time(time_t *timep)*/
10962 time_t Perl_my_time(pTHX_ time_t *timep)
10963 {
10964   time_t when;
10965   struct tm *tm_p;
10966
10967   if (gmtime_emulation_type == 0) {
10968     int dstnow;
10969     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10970                               /* results of calls to gmtime() and localtime() */
10971                               /* for same &base */
10972
10973     gmtime_emulation_type++;
10974     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10975       char off[LNM$C_NAMLENGTH+1];;
10976
10977       gmtime_emulation_type++;
10978       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10979         gmtime_emulation_type++;
10980         utc_offset_secs = 0;
10981         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10982       }
10983       else { utc_offset_secs = atol(off); }
10984     }
10985     else { /* We've got a working gmtime() */
10986       struct tm gmt, local;
10987
10988       gmt = *tm_p;
10989       tm_p = localtime(&base);
10990       local = *tm_p;
10991       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10992       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10993       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10994       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10995     }
10996   }
10997
10998   when = time(NULL);
10999 # ifdef VMSISH_TIME
11000 # ifdef RTL_USES_UTC
11001   if (VMSISH_TIME) when = _toloc(when);
11002 # else
11003   if (!VMSISH_TIME) when = _toutc(when);
11004 # endif
11005 # endif
11006   if (timep != NULL) *timep = when;
11007   return when;
11008
11009 }  /* end of my_time() */
11010 /*}}}*/
11011
11012
11013 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11014 struct tm *
11015 Perl_my_gmtime(pTHX_ const time_t *timep)
11016 {
11017   char *p;
11018   time_t when;
11019   struct tm *rsltmp;
11020
11021   if (timep == NULL) {
11022     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11023     return NULL;
11024   }
11025   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11026
11027   when = *timep;
11028 # ifdef VMSISH_TIME
11029   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11030 #  endif
11031 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
11032   return gmtime(&when);
11033 # else
11034   /* CRTL localtime() wants local time as input, so does no tz correction */
11035   rsltmp = localtime(&when);
11036   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
11037   return rsltmp;
11038 #endif
11039 }  /* end of my_gmtime() */
11040 /*}}}*/
11041
11042
11043 /*{{{struct tm *my_localtime(const time_t *timep)*/
11044 struct tm *
11045 Perl_my_localtime(pTHX_ const time_t *timep)
11046 {
11047   time_t when, whenutc;
11048   struct tm *rsltmp;
11049   int dst, offset;
11050
11051   if (timep == NULL) {
11052     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11053     return NULL;
11054   }
11055   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11056   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11057
11058   when = *timep;
11059 # ifdef RTL_USES_UTC
11060 # ifdef VMSISH_TIME
11061   if (VMSISH_TIME) when = _toutc(when);
11062 # endif
11063   /* CRTL localtime() wants UTC as input, does tz correction itself */
11064   return localtime(&when);
11065
11066 # else /* !RTL_USES_UTC */
11067   whenutc = when;
11068 # ifdef VMSISH_TIME
11069   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
11070   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
11071 # endif
11072   dst = -1;
11073 #ifndef RTL_USES_UTC
11074   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
11075       when = whenutc - offset;                   /* pseudolocal time*/
11076   }
11077 # endif
11078   /* CRTL localtime() wants local time as input, so does no tz correction */
11079   rsltmp = localtime(&when);
11080   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11081   return rsltmp;
11082 # endif
11083
11084 } /*  end of my_localtime() */
11085 /*}}}*/
11086
11087 /* Reset definitions for later calls */
11088 #define gmtime(t)    my_gmtime(t)
11089 #define localtime(t) my_localtime(t)
11090 #define time(t)      my_time(t)
11091
11092
11093 /* my_utime - update modification/access time of a file
11094  *
11095  * VMS 7.3 and later implementation
11096  * Only the UTC translation is home-grown. The rest is handled by the
11097  * CRTL utime(), which will take into account the relevant feature
11098  * logicals and ODS-5 volume characteristics for true access times.
11099  *
11100  * pre VMS 7.3 implementation:
11101  * The calling sequence is identical to POSIX utime(), but under
11102  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11103  * not maintain access times.  Restrictions differ from the POSIX
11104  * definition in that the time can be changed as long as the
11105  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11106  * no separate checks are made to insure that the caller is the
11107  * owner of the file or has special privs enabled.
11108  * Code here is based on Joe Meadows' FILE utility.
11109  *
11110  */
11111
11112 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11113  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11114  * in 100 ns intervals.
11115  */
11116 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11117
11118 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11119 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11120 {
11121 #if __CRTL_VER >= 70300000
11122   struct utimbuf utc_utimes, *utc_utimesp;
11123
11124   if (utimes != NULL) {
11125     utc_utimes.actime = utimes->actime;
11126     utc_utimes.modtime = utimes->modtime;
11127 # ifdef VMSISH_TIME
11128     /* If input was local; convert to UTC for sys svc */
11129     if (VMSISH_TIME) {
11130       utc_utimes.actime = _toutc(utimes->actime);
11131       utc_utimes.modtime = _toutc(utimes->modtime);
11132     }
11133 # endif
11134     utc_utimesp = &utc_utimes;
11135   }
11136   else {
11137     utc_utimesp = NULL;
11138   }
11139
11140   return utime(file, utc_utimesp);
11141
11142 #else /* __CRTL_VER < 70300000 */
11143
11144   register int i;
11145   int sts;
11146   long int bintime[2], len = 2, lowbit, unixtime,
11147            secscale = 10000000; /* seconds --> 100 ns intervals */
11148   unsigned long int chan, iosb[2], retsts;
11149   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11150   struct FAB myfab = cc$rms_fab;
11151   struct NAM mynam = cc$rms_nam;
11152 #if defined (__DECC) && defined (__VAX)
11153   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11154    * at least through VMS V6.1, which causes a type-conversion warning.
11155    */
11156 #  pragma message save
11157 #  pragma message disable cvtdiftypes
11158 #endif
11159   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11160   struct fibdef myfib;
11161 #if defined (__DECC) && defined (__VAX)
11162   /* This should be right after the declaration of myatr, but due
11163    * to a bug in VAX DEC C, this takes effect a statement early.
11164    */
11165 #  pragma message restore
11166 #endif
11167   /* cast ok for read only parameter */
11168   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11169                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11170                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11171
11172   if (file == NULL || *file == '\0') {
11173     SETERRNO(ENOENT, LIB$_INVARG);
11174     return -1;
11175   }
11176
11177   /* Convert to VMS format ensuring that it will fit in 255 characters */
11178   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11179       SETERRNO(ENOENT, LIB$_INVARG);
11180       return -1;
11181   }
11182   if (utimes != NULL) {
11183     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11184      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11185      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11186      * as input, we force the sign bit to be clear by shifting unixtime right
11187      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11188      */
11189     lowbit = (utimes->modtime & 1) ? secscale : 0;
11190     unixtime = (long int) utimes->modtime;
11191 #   ifdef VMSISH_TIME
11192     /* If input was UTC; convert to local for sys svc */
11193     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11194 #   endif
11195     unixtime >>= 1;  secscale <<= 1;
11196     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11197     if (!(retsts & 1)) {
11198       SETERRNO(EVMSERR, retsts);
11199       return -1;
11200     }
11201     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11202     if (!(retsts & 1)) {
11203       SETERRNO(EVMSERR, retsts);
11204       return -1;
11205     }
11206   }
11207   else {
11208     /* Just get the current time in VMS format directly */
11209     retsts = sys$gettim(bintime);
11210     if (!(retsts & 1)) {
11211       SETERRNO(EVMSERR, retsts);
11212       return -1;
11213     }
11214   }
11215
11216   myfab.fab$l_fna = vmsspec;
11217   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11218   myfab.fab$l_nam = &mynam;
11219   mynam.nam$l_esa = esa;
11220   mynam.nam$b_ess = (unsigned char) sizeof esa;
11221   mynam.nam$l_rsa = rsa;
11222   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11223   if (decc_efs_case_preserve)
11224       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11225
11226   /* Look for the file to be affected, letting RMS parse the file
11227    * specification for us as well.  I have set errno using only
11228    * values documented in the utime() man page for VMS POSIX.
11229    */
11230   retsts = sys$parse(&myfab,0,0);
11231   if (!(retsts & 1)) {
11232     set_vaxc_errno(retsts);
11233     if      (retsts == RMS$_PRV) set_errno(EACCES);
11234     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11235     else                         set_errno(EVMSERR);
11236     return -1;
11237   }
11238   retsts = sys$search(&myfab,0,0);
11239   if (!(retsts & 1)) {
11240     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11241     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11242     set_vaxc_errno(retsts);
11243     if      (retsts == RMS$_PRV) set_errno(EACCES);
11244     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11245     else                         set_errno(EVMSERR);
11246     return -1;
11247   }
11248
11249   devdsc.dsc$w_length = mynam.nam$b_dev;
11250   /* cast ok for read only parameter */
11251   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11252
11253   retsts = sys$assign(&devdsc,&chan,0,0);
11254   if (!(retsts & 1)) {
11255     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11256     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11257     set_vaxc_errno(retsts);
11258     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11259     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11260     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11261     else                               set_errno(EVMSERR);
11262     return -1;
11263   }
11264
11265   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11266   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11267
11268   memset((void *) &myfib, 0, sizeof myfib);
11269 #if defined(__DECC) || defined(__DECCXX)
11270   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11271   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11272   /* This prevents the revision time of the file being reset to the current
11273    * time as a result of our IO$_MODIFY $QIO. */
11274   myfib.fib$l_acctl = FIB$M_NORECORD;
11275 #else
11276   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11277   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11278   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11279 #endif
11280   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11281   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11282   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11283   _ckvmssts(sys$dassgn(chan));
11284   if (retsts & 1) retsts = iosb[0];
11285   if (!(retsts & 1)) {
11286     set_vaxc_errno(retsts);
11287     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11288     else                      set_errno(EVMSERR);
11289     return -1;
11290   }
11291
11292   return 0;
11293
11294 #endif /* #if __CRTL_VER >= 70300000 */
11295
11296 }  /* end of my_utime() */
11297 /*}}}*/
11298
11299 /*
11300  * flex_stat, flex_lstat, flex_fstat
11301  * basic stat, but gets it right when asked to stat
11302  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11303  */
11304
11305 #ifndef _USE_STD_STAT
11306 /* encode_dev packs a VMS device name string into an integer to allow
11307  * simple comparisons. This can be used, for example, to check whether two
11308  * files are located on the same device, by comparing their encoded device
11309  * names. Even a string comparison would not do, because stat() reuses the
11310  * device name buffer for each call; so without encode_dev, it would be
11311  * necessary to save the buffer and use strcmp (this would mean a number of
11312  * changes to the standard Perl code, to say nothing of what a Perl script
11313  * would have to do.
11314  *
11315  * The device lock id, if it exists, should be unique (unless perhaps compared
11316  * with lock ids transferred from other nodes). We have a lock id if the disk is
11317  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11318  * device names. Thus we use the lock id in preference, and only if that isn't
11319  * available, do we try to pack the device name into an integer (flagged by
11320  * the sign bit (LOCKID_MASK) being set).
11321  *
11322  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11323  * name and its encoded form, but it seems very unlikely that we will find
11324  * two files on different disks that share the same encoded device names,
11325  * and even more remote that they will share the same file id (if the test
11326  * is to check for the same file).
11327  *
11328  * A better method might be to use sys$device_scan on the first call, and to
11329  * search for the device, returning an index into the cached array.
11330  * The number returned would be more intelligible.
11331  * This is probably not worth it, and anyway would take quite a bit longer
11332  * on the first call.
11333  */
11334 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11335 static mydev_t encode_dev (pTHX_ const char *dev)
11336 {
11337   int i;
11338   unsigned long int f;
11339   mydev_t enc;
11340   char c;
11341   const char *q;
11342
11343   if (!dev || !dev[0]) return 0;
11344
11345 #if LOCKID_MASK
11346   {
11347     struct dsc$descriptor_s dev_desc;
11348     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11349
11350     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11351        can try that first. */
11352     dev_desc.dsc$w_length =  strlen (dev);
11353     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11354     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11355     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11356     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11357     if (!$VMS_STATUS_SUCCESS(status)) {
11358       switch (status) {
11359         case SS$_NOSUCHDEV:
11360           SETERRNO(ENODEV, status);
11361           return 0;
11362         default:
11363           _ckvmssts(status);
11364       }
11365     }
11366     if (lockid) return (lockid & ~LOCKID_MASK);
11367   }
11368 #endif
11369
11370   /* Otherwise we try to encode the device name */
11371   enc = 0;
11372   f = 1;
11373   i = 0;
11374   for (q = dev + strlen(dev); q--; q >= dev) {
11375     if (*q == ':')
11376         break;
11377     if (isdigit (*q))
11378       c= (*q) - '0';
11379     else if (isalpha (toupper (*q)))
11380       c= toupper (*q) - 'A' + (char)10;
11381     else
11382       continue; /* Skip '$'s */
11383     i++;
11384     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11385     if (i>1) f *= 36;
11386     enc += f * (unsigned long int) c;
11387   }
11388   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11389
11390 }  /* end of encode_dev() */
11391 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11392         device_no = encode_dev(aTHX_ devname)
11393 #else
11394 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11395         device_no = new_dev_no
11396 #endif
11397
11398 static int
11399 is_null_device(name)
11400     const char *name;
11401 {
11402   if (decc_bug_devnull != 0) {
11403     if (strncmp("/dev/null", name, 9) == 0)
11404       return 1;
11405   }
11406     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11407        The underscore prefix, controller letter, and unit number are
11408        independently optional; for our purposes, the colon punctuation
11409        is not.  The colon can be trailed by optional directory and/or
11410        filename, but two consecutive colons indicates a nodename rather
11411        than a device.  [pr]  */
11412   if (*name == '_') ++name;
11413   if (tolower(*name++) != 'n') return 0;
11414   if (tolower(*name++) != 'l') return 0;
11415   if (tolower(*name) == 'a') ++name;
11416   if (*name == '0') ++name;
11417   return (*name++ == ':') && (*name != ':');
11418 }
11419
11420
11421 static I32
11422 Perl_cando_by_name_int
11423    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11424 {
11425   char usrname[L_cuserid];
11426   struct dsc$descriptor_s usrdsc =
11427          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11428   char *vmsname = NULL, *fileified = NULL;
11429   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11430   unsigned short int retlen, trnlnm_iter_count;
11431   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11432   union prvdef curprv;
11433   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11434          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11435          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11436   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11437          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11438          {0,0,0,0}};
11439   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11440          {0,0,0,0}};
11441   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11442   Stat_t st;
11443   static int profile_context = -1;
11444
11445   if (!fname || !*fname) return FALSE;
11446
11447   /* Make sure we expand logical names, since sys$check_access doesn't */
11448   fileified = PerlMem_malloc(VMS_MAXRSS);
11449   if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11450   if (!strpbrk(fname,"/]>:")) {
11451       strcpy(fileified,fname);
11452       trnlnm_iter_count = 0;
11453       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11454         trnlnm_iter_count++;
11455         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11456       }
11457       fname = fileified;
11458   }
11459
11460   vmsname = PerlMem_malloc(VMS_MAXRSS);
11461   if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11462   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11463     /* Don't know if already in VMS format, so make sure */
11464     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11465       PerlMem_free(fileified);
11466       PerlMem_free(vmsname);
11467       return FALSE;
11468     }
11469   }
11470   else {
11471     strcpy(vmsname,fname);
11472   }
11473
11474   /* sys$check_access needs a file spec, not a directory spec.
11475    * Don't use flex_stat here, as that depends on thread context
11476    * having been initialized, and we may get here during startup.
11477    */
11478
11479   retlen = namdsc.dsc$w_length = strlen(vmsname);
11480   if (vmsname[retlen-1] == ']'
11481       || vmsname[retlen-1] == '>'
11482       || vmsname[retlen-1] == ':'
11483       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11484
11485       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11486         PerlMem_free(fileified);
11487         PerlMem_free(vmsname);
11488         return FALSE;
11489       }
11490       fname = fileified;
11491   }
11492   else {
11493       fname = vmsname;
11494   }
11495
11496   retlen = namdsc.dsc$w_length = strlen(fname);
11497   namdsc.dsc$a_pointer = (char *)fname;
11498
11499   switch (bit) {
11500     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11501       access = ARM$M_EXECUTE;
11502       flags = CHP$M_READ;
11503       break;
11504     case S_IRUSR: case S_IRGRP: case S_IROTH:
11505       access = ARM$M_READ;
11506       flags = CHP$M_READ | CHP$M_USEREADALL;
11507       break;
11508     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11509       access = ARM$M_WRITE;
11510       flags = CHP$M_READ | CHP$M_WRITE;
11511       break;
11512     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11513       access = ARM$M_DELETE;
11514       flags = CHP$M_READ | CHP$M_WRITE;
11515       break;
11516     default:
11517       if (fileified != NULL)
11518         PerlMem_free(fileified);
11519       if (vmsname != NULL)
11520         PerlMem_free(vmsname);
11521       return FALSE;
11522   }
11523
11524   /* Before we call $check_access, create a user profile with the current
11525    * process privs since otherwise it just uses the default privs from the
11526    * UAF and might give false positives or negatives.  This only works on
11527    * VMS versions v6.0 and later since that's when sys$create_user_profile
11528    * became available.
11529    */
11530
11531   /* get current process privs and username */
11532   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11533   _ckvmssts(iosb[0]);
11534
11535 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11536
11537   /* find out the space required for the profile */
11538   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11539                                     &usrprodsc.dsc$w_length,&profile_context));
11540
11541   /* allocate space for the profile and get it filled in */
11542   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11543   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11544   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11545                                     &usrprodsc.dsc$w_length,&profile_context));
11546
11547   /* use the profile to check access to the file; free profile & analyze results */
11548   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11549   PerlMem_free(usrprodsc.dsc$a_pointer);
11550   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11551
11552 #else
11553
11554   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11555
11556 #endif
11557
11558   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11559       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11560       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11561     set_vaxc_errno(retsts);
11562     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11563     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11564     else set_errno(ENOENT);
11565     if (fileified != NULL)
11566       PerlMem_free(fileified);
11567     if (vmsname != NULL)
11568       PerlMem_free(vmsname);
11569     return FALSE;
11570   }
11571   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11572     if (fileified != NULL)
11573       PerlMem_free(fileified);
11574     if (vmsname != NULL)
11575       PerlMem_free(vmsname);
11576     return TRUE;
11577   }
11578   _ckvmssts(retsts);
11579
11580   if (fileified != NULL)
11581     PerlMem_free(fileified);
11582   if (vmsname != NULL)
11583     PerlMem_free(vmsname);
11584   return FALSE;  /* Should never get here */
11585
11586 }
11587
11588 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11589 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11590  * subset of the applicable information.
11591  */
11592 bool
11593 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11594 {
11595   return cando_by_name_int
11596         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11597 }  /* end of cando() */
11598 /*}}}*/
11599
11600
11601 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11602 I32
11603 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11604 {
11605    return cando_by_name_int(bit, effective, fname, 0);
11606
11607 }  /* end of cando_by_name() */
11608 /*}}}*/
11609
11610
11611 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11612 int
11613 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11614 {
11615   if (!fstat(fd,(stat_t *) statbufp)) {
11616     char *cptr;
11617     char *vms_filename;
11618     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11619     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11620
11621     /* Save name for cando by name in VMS format */
11622     cptr = getname(fd, vms_filename, 1);
11623
11624     /* This should not happen, but just in case */
11625     if (cptr == NULL) {
11626         statbufp->st_devnam[0] = 0;
11627     }
11628     else {
11629         /* Make sure that the saved name fits in 255 characters */
11630         cptr = do_rmsexpand
11631                        (vms_filename,
11632                         statbufp->st_devnam,
11633                         0,
11634                         NULL,
11635                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11636                         NULL,
11637                         NULL);
11638         if (cptr == NULL)
11639             statbufp->st_devnam[0] = 0;
11640     }
11641     PerlMem_free(vms_filename);
11642
11643     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11644     VMS_DEVICE_ENCODE
11645         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11646
11647 #   ifdef RTL_USES_UTC
11648 #   ifdef VMSISH_TIME
11649     if (VMSISH_TIME) {
11650       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11651       statbufp->st_atime = _toloc(statbufp->st_atime);
11652       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11653     }
11654 #   endif
11655 #   else
11656 #   ifdef VMSISH_TIME
11657     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11658 #   else
11659     if (1) {
11660 #   endif
11661       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11662       statbufp->st_atime = _toutc(statbufp->st_atime);
11663       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11664     }
11665 #endif
11666     return 0;
11667   }
11668   return -1;
11669
11670 }  /* end of flex_fstat() */
11671 /*}}}*/
11672
11673 #if !defined(__VAX) && __CRTL_VER >= 80200000
11674 #ifdef lstat
11675 #undef lstat
11676 #endif
11677 #else
11678 #ifdef lstat
11679 #undef lstat
11680 #endif
11681 #define lstat(_x, _y) stat(_x, _y)
11682 #endif
11683
11684 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11685
11686 static int
11687 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11688 {
11689     char fileified[VMS_MAXRSS];
11690     char temp_fspec[VMS_MAXRSS];
11691     char *save_spec;
11692     int retval = -1;
11693     int saved_errno, saved_vaxc_errno;
11694
11695     if (!fspec) return retval;
11696     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11697     strcpy(temp_fspec, fspec);
11698
11699     if (decc_bug_devnull != 0) {
11700       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11701         memset(statbufp,0,sizeof *statbufp);
11702         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11703         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11704         statbufp->st_uid = 0x00010001;
11705         statbufp->st_gid = 0x0001;
11706         time((time_t *)&statbufp->st_mtime);
11707         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11708         return 0;
11709       }
11710     }
11711
11712     /* Try for a directory name first.  If fspec contains a filename without
11713      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11714      * and sea:[wine.dark]water. exist, we prefer the directory here.
11715      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11716      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11717      * the file with null type, specify this by calling flex_stat() with
11718      * a '.' at the end of fspec.
11719      *
11720      * If we are in Posix filespec mode, accept the filename as is.
11721      */
11722
11723
11724 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11725   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11726    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11727    */
11728   if (!decc_efs_charset)
11729     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11730 #endif
11731
11732 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11733   if (decc_posix_compliant_pathnames == 0) {
11734 #endif
11735     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11736       if (lstat_flag == 0)
11737         retval = stat(fileified,(stat_t *) statbufp);
11738       else
11739         retval = lstat(fileified,(stat_t *) statbufp);
11740       save_spec = fileified;
11741     }
11742     if (retval) {
11743       if (lstat_flag == 0)
11744         retval = stat(temp_fspec,(stat_t *) statbufp);
11745       else
11746         retval = lstat(temp_fspec,(stat_t *) statbufp);
11747       save_spec = temp_fspec;
11748     }
11749 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11750   } else {
11751     if (lstat_flag == 0)
11752       retval = stat(temp_fspec,(stat_t *) statbufp);
11753     else
11754       retval = lstat(temp_fspec,(stat_t *) statbufp);
11755       save_spec = temp_fspec;
11756   }
11757 #endif
11758
11759 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11760   /* As you were... */
11761   if (!decc_efs_charset)
11762     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11763 #endif
11764
11765     if (!retval) {
11766     char * cptr;
11767       cptr = do_rmsexpand
11768        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11769       if (cptr == NULL)
11770         statbufp->st_devnam[0] = 0;
11771
11772       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11773       VMS_DEVICE_ENCODE
11774         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11775 #     ifdef RTL_USES_UTC
11776 #     ifdef VMSISH_TIME
11777       if (VMSISH_TIME) {
11778         statbufp->st_mtime = _toloc(statbufp->st_mtime);
11779         statbufp->st_atime = _toloc(statbufp->st_atime);
11780         statbufp->st_ctime = _toloc(statbufp->st_ctime);
11781       }
11782 #     endif
11783 #     else
11784 #     ifdef VMSISH_TIME
11785       if (!VMSISH_TIME) { /* Return UTC instead of local time */
11786 #     else
11787       if (1) {
11788 #     endif
11789         statbufp->st_mtime = _toutc(statbufp->st_mtime);
11790         statbufp->st_atime = _toutc(statbufp->st_atime);
11791         statbufp->st_ctime = _toutc(statbufp->st_ctime);
11792       }
11793 #     endif
11794     }
11795     /* If we were successful, leave errno where we found it */
11796     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11797     return retval;
11798
11799 }  /* end of flex_stat_int() */
11800
11801
11802 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11803 int
11804 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11805 {
11806    return flex_stat_int(fspec, statbufp, 0);
11807 }
11808 /*}}}*/
11809
11810 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11811 int
11812 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11813 {
11814    return flex_stat_int(fspec, statbufp, 1);
11815 }
11816 /*}}}*/
11817
11818
11819 /*{{{char *my_getlogin()*/
11820 /* VMS cuserid == Unix getlogin, except calling sequence */
11821 char *
11822 my_getlogin(void)
11823 {
11824     static char user[L_cuserid];
11825     return cuserid(user);
11826 }
11827 /*}}}*/
11828
11829
11830 /*  rmscopy - copy a file using VMS RMS routines
11831  *
11832  *  Copies contents and attributes of spec_in to spec_out, except owner
11833  *  and protection information.  Name and type of spec_in are used as
11834  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11835  *  should try to propagate timestamps from the input file to the output file.
11836  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11837  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11838  *  propagated to the output file at creation iff the output file specification
11839  *  did not contain an explicit name or type, and the revision date is always
11840  *  updated at the end of the copy operation.  If it is greater than 0, then
11841  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11842  *  other than the revision date should be propagated, and bit 1 indicates
11843  *  that the revision date should be propagated.
11844  *
11845  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11846  *
11847  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11848  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11849  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11850  * as part of the Perl standard distribution under the terms of the
11851  * GNU General Public License or the Perl Artistic License.  Copies
11852  * of each may be found in the Perl standard distribution.
11853  */ /* FIXME */
11854 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11855 int
11856 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11857 {
11858     char *vmsin, * vmsout, *esa, *esa_out,
11859          *rsa, *ubf;
11860     unsigned long int i, sts, sts2;
11861     int dna_len;
11862     struct FAB fab_in, fab_out;
11863     struct RAB rab_in, rab_out;
11864     rms_setup_nam(nam);
11865     rms_setup_nam(nam_out);
11866     struct XABDAT xabdat;
11867     struct XABFHC xabfhc;
11868     struct XABRDT xabrdt;
11869     struct XABSUM xabsum;
11870
11871     vmsin = PerlMem_malloc(VMS_MAXRSS);
11872     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11873     vmsout = PerlMem_malloc(VMS_MAXRSS);
11874     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11875     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11876         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11877       PerlMem_free(vmsin);
11878       PerlMem_free(vmsout);
11879       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11880       return 0;
11881     }
11882
11883     esa = PerlMem_malloc(VMS_MAXRSS);
11884     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11885     fab_in = cc$rms_fab;
11886     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11887     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11888     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11889     fab_in.fab$l_fop = FAB$M_SQO;
11890     rms_bind_fab_nam(fab_in, nam);
11891     fab_in.fab$l_xab = (void *) &xabdat;
11892
11893     rsa = PerlMem_malloc(VMS_MAXRSS);
11894     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11895     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11896     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11897     rms_nam_esl(nam) = 0;
11898     rms_nam_rsl(nam) = 0;
11899     rms_nam_esll(nam) = 0;
11900     rms_nam_rsll(nam) = 0;
11901 #ifdef NAM$M_NO_SHORT_UPCASE
11902     if (decc_efs_case_preserve)
11903         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11904 #endif
11905
11906     xabdat = cc$rms_xabdat;        /* To get creation date */
11907     xabdat.xab$l_nxt = (void *) &xabfhc;
11908
11909     xabfhc = cc$rms_xabfhc;        /* To get record length */
11910     xabfhc.xab$l_nxt = (void *) &xabsum;
11911
11912     xabsum = cc$rms_xabsum;        /* To get key and area information */
11913
11914     if (!((sts = sys$open(&fab_in)) & 1)) {
11915       PerlMem_free(vmsin);
11916       PerlMem_free(vmsout);
11917       PerlMem_free(esa);
11918       PerlMem_free(rsa);
11919       set_vaxc_errno(sts);
11920       switch (sts) {
11921         case RMS$_FNF: case RMS$_DNF:
11922           set_errno(ENOENT); break;
11923         case RMS$_DIR:
11924           set_errno(ENOTDIR); break;
11925         case RMS$_DEV:
11926           set_errno(ENODEV); break;
11927         case RMS$_SYN:
11928           set_errno(EINVAL); break;
11929         case RMS$_PRV:
11930           set_errno(EACCES); break;
11931         default:
11932           set_errno(EVMSERR);
11933       }
11934       return 0;
11935     }
11936
11937     nam_out = nam;
11938     fab_out = fab_in;
11939     fab_out.fab$w_ifi = 0;
11940     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11941     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11942     fab_out.fab$l_fop = FAB$M_SQO;
11943     rms_bind_fab_nam(fab_out, nam_out);
11944     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11945     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11946     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11947     esa_out = PerlMem_malloc(VMS_MAXRSS);
11948     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11949     rms_set_rsa(nam_out, NULL, 0);
11950     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11951
11952     if (preserve_dates == 0) {  /* Act like DCL COPY */
11953       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11954       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11955       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11956         PerlMem_free(vmsin);
11957         PerlMem_free(vmsout);
11958         PerlMem_free(esa);
11959         PerlMem_free(rsa);
11960         PerlMem_free(esa_out);
11961         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11962         set_vaxc_errno(sts);
11963         return 0;
11964       }
11965       fab_out.fab$l_xab = (void *) &xabdat;
11966       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11967         preserve_dates = 1;
11968     }
11969     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11970       preserve_dates =0;      /* bitmask from this point forward   */
11971
11972     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11973     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11974       PerlMem_free(vmsin);
11975       PerlMem_free(vmsout);
11976       PerlMem_free(esa);
11977       PerlMem_free(rsa);
11978       PerlMem_free(esa_out);
11979       set_vaxc_errno(sts);
11980       switch (sts) {
11981         case RMS$_DNF:
11982           set_errno(ENOENT); break;
11983         case RMS$_DIR:
11984           set_errno(ENOTDIR); break;
11985         case RMS$_DEV:
11986           set_errno(ENODEV); break;
11987         case RMS$_SYN:
11988           set_errno(EINVAL); break;
11989         case RMS$_PRV:
11990           set_errno(EACCES); break;
11991         default:
11992           set_errno(EVMSERR);
11993       }
11994       return 0;
11995     }
11996     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11997     if (preserve_dates & 2) {
11998       /* sys$close() will process xabrdt, not xabdat */
11999       xabrdt = cc$rms_xabrdt;
12000 #ifndef __GNUC__
12001       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12002 #else
12003       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12004        * is unsigned long[2], while DECC & VAXC use a struct */
12005       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12006 #endif
12007       fab_out.fab$l_xab = (void *) &xabrdt;
12008     }
12009
12010     ubf = PerlMem_malloc(32256);
12011     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12012     rab_in = cc$rms_rab;
12013     rab_in.rab$l_fab = &fab_in;
12014     rab_in.rab$l_rop = RAB$M_BIO;
12015     rab_in.rab$l_ubf = ubf;
12016     rab_in.rab$w_usz = 32256;
12017     if (!((sts = sys$connect(&rab_in)) & 1)) {
12018       sys$close(&fab_in); sys$close(&fab_out);
12019       PerlMem_free(vmsin);
12020       PerlMem_free(vmsout);
12021       PerlMem_free(esa);
12022       PerlMem_free(ubf);
12023       PerlMem_free(rsa);
12024       PerlMem_free(esa_out);
12025       set_errno(EVMSERR); set_vaxc_errno(sts);
12026       return 0;
12027     }
12028
12029     rab_out = cc$rms_rab;
12030     rab_out.rab$l_fab = &fab_out;
12031     rab_out.rab$l_rbf = ubf;
12032     if (!((sts = sys$connect(&rab_out)) & 1)) {
12033       sys$close(&fab_in); sys$close(&fab_out);
12034       PerlMem_free(vmsin);
12035       PerlMem_free(vmsout);
12036       PerlMem_free(esa);
12037       PerlMem_free(ubf);
12038       PerlMem_free(rsa);
12039       PerlMem_free(esa_out);
12040       set_errno(EVMSERR); set_vaxc_errno(sts);
12041       return 0;
12042     }
12043
12044     while ((sts = sys$read(&rab_in))) {  /* always true  */
12045       if (sts == RMS$_EOF) break;
12046       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12047       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12048         sys$close(&fab_in); sys$close(&fab_out);
12049         PerlMem_free(vmsin);
12050         PerlMem_free(vmsout);
12051         PerlMem_free(esa);
12052         PerlMem_free(ubf);
12053         PerlMem_free(rsa);
12054         PerlMem_free(esa_out);
12055         set_errno(EVMSERR); set_vaxc_errno(sts);
12056         return 0;
12057       }
12058     }
12059
12060
12061     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12062     sys$close(&fab_in);  sys$close(&fab_out);
12063     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12064     if (!(sts & 1)) {
12065       PerlMem_free(vmsin);
12066       PerlMem_free(vmsout);
12067       PerlMem_free(esa);
12068       PerlMem_free(ubf);
12069       PerlMem_free(rsa);
12070       PerlMem_free(esa_out);
12071       set_errno(EVMSERR); set_vaxc_errno(sts);
12072       return 0;
12073     }
12074
12075     PerlMem_free(vmsin);
12076     PerlMem_free(vmsout);
12077     PerlMem_free(esa);
12078     PerlMem_free(ubf);
12079     PerlMem_free(rsa);
12080     PerlMem_free(esa_out);
12081     return 1;
12082
12083 }  /* end of rmscopy() */
12084 /*}}}*/
12085
12086
12087 /***  The following glue provides 'hooks' to make some of the routines
12088  * from this file available from Perl.  These routines are sufficiently
12089  * basic, and are required sufficiently early in the build process,
12090  * that's it's nice to have them available to miniperl as well as the
12091  * full Perl, so they're set up here instead of in an extension.  The
12092  * Perl code which handles importation of these names into a given
12093  * package lives in [.VMS]Filespec.pm in @INC.
12094  */
12095
12096 void
12097 rmsexpand_fromperl(pTHX_ CV *cv)
12098 {
12099   dXSARGS;
12100   char *fspec, *defspec = NULL, *rslt;
12101   STRLEN n_a;
12102   int fs_utf8, dfs_utf8;
12103
12104   fs_utf8 = 0;
12105   dfs_utf8 = 0;
12106   if (!items || items > 2)
12107     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12108   fspec = SvPV(ST(0),n_a);
12109   fs_utf8 = SvUTF8(ST(0));
12110   if (!fspec || !*fspec) XSRETURN_UNDEF;
12111   if (items == 2) {
12112     defspec = SvPV(ST(1),n_a);
12113     dfs_utf8 = SvUTF8(ST(1));
12114   }
12115   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12116   ST(0) = sv_newmortal();
12117   if (rslt != NULL) {
12118     sv_usepvn(ST(0),rslt,strlen(rslt));
12119     if (fs_utf8) {
12120         SvUTF8_on(ST(0));
12121     }
12122   }
12123   XSRETURN(1);
12124 }
12125
12126 void
12127 vmsify_fromperl(pTHX_ CV *cv)
12128 {
12129   dXSARGS;
12130   char *vmsified;
12131   STRLEN n_a;
12132   int utf8_fl;
12133
12134   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12135   utf8_fl = SvUTF8(ST(0));
12136   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12137   ST(0) = sv_newmortal();
12138   if (vmsified != NULL) {
12139     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12140     if (utf8_fl) {
12141         SvUTF8_on(ST(0));
12142     }
12143   }
12144   XSRETURN(1);
12145 }
12146
12147 void
12148 unixify_fromperl(pTHX_ CV *cv)
12149 {
12150   dXSARGS;
12151   char *unixified;
12152   STRLEN n_a;
12153   int utf8_fl;
12154
12155   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12156   utf8_fl = SvUTF8(ST(0));
12157   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12158   ST(0) = sv_newmortal();
12159   if (unixified != NULL) {
12160     sv_usepvn(ST(0),unixified,strlen(unixified));
12161     if (utf8_fl) {
12162         SvUTF8_on(ST(0));
12163     }
12164   }
12165   XSRETURN(1);
12166 }
12167
12168 void
12169 fileify_fromperl(pTHX_ CV *cv)
12170 {
12171   dXSARGS;
12172   char *fileified;
12173   STRLEN n_a;
12174   int utf8_fl;
12175
12176   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12177   utf8_fl = SvUTF8(ST(0));
12178   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12179   ST(0) = sv_newmortal();
12180   if (fileified != NULL) {
12181     sv_usepvn(ST(0),fileified,strlen(fileified));
12182     if (utf8_fl) {
12183         SvUTF8_on(ST(0));
12184     }
12185   }
12186   XSRETURN(1);
12187 }
12188
12189 void
12190 pathify_fromperl(pTHX_ CV *cv)
12191 {
12192   dXSARGS;
12193   char *pathified;
12194   STRLEN n_a;
12195   int utf8_fl;
12196
12197   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12198   utf8_fl = SvUTF8(ST(0));
12199   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12200   ST(0) = sv_newmortal();
12201   if (pathified != NULL) {
12202     sv_usepvn(ST(0),pathified,strlen(pathified));
12203     if (utf8_fl) {
12204         SvUTF8_on(ST(0));
12205     }
12206   }
12207   XSRETURN(1);
12208 }
12209
12210 void
12211 vmspath_fromperl(pTHX_ CV *cv)
12212 {
12213   dXSARGS;
12214   char *vmspath;
12215   STRLEN n_a;
12216   int utf8_fl;
12217
12218   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12219   utf8_fl = SvUTF8(ST(0));
12220   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12221   ST(0) = sv_newmortal();
12222   if (vmspath != NULL) {
12223     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12224     if (utf8_fl) {
12225         SvUTF8_on(ST(0));
12226     }
12227   }
12228   XSRETURN(1);
12229 }
12230
12231 void
12232 unixpath_fromperl(pTHX_ CV *cv)
12233 {
12234   dXSARGS;
12235   char *unixpath;
12236   STRLEN n_a;
12237   int utf8_fl;
12238
12239   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12240   utf8_fl = SvUTF8(ST(0));
12241   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12242   ST(0) = sv_newmortal();
12243   if (unixpath != NULL) {
12244     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12245     if (utf8_fl) {
12246         SvUTF8_on(ST(0));
12247     }
12248   }
12249   XSRETURN(1);
12250 }
12251
12252 void
12253 candelete_fromperl(pTHX_ CV *cv)
12254 {
12255   dXSARGS;
12256   char *fspec, *fsp;
12257   SV *mysv;
12258   IO *io;
12259   STRLEN n_a;
12260
12261   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12262
12263   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12264   Newx(fspec, VMS_MAXRSS, char);
12265   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12266   if (SvTYPE(mysv) == SVt_PVGV) {
12267     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12268       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12269       ST(0) = &PL_sv_no;
12270       Safefree(fspec);
12271       XSRETURN(1);
12272     }
12273     fsp = fspec;
12274   }
12275   else {
12276     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12277       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12278       ST(0) = &PL_sv_no;
12279       Safefree(fspec);
12280       XSRETURN(1);
12281     }
12282   }
12283
12284   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12285   Safefree(fspec);
12286   XSRETURN(1);
12287 }
12288
12289 void
12290 rmscopy_fromperl(pTHX_ CV *cv)
12291 {
12292   dXSARGS;
12293   char *inspec, *outspec, *inp, *outp;
12294   int date_flag;
12295   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12296                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12297   unsigned long int sts;
12298   SV *mysv;
12299   IO *io;
12300   STRLEN n_a;
12301
12302   if (items < 2 || items > 3)
12303     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12304
12305   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12306   Newx(inspec, VMS_MAXRSS, char);
12307   if (SvTYPE(mysv) == SVt_PVGV) {
12308     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12309       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12310       ST(0) = &PL_sv_no;
12311       Safefree(inspec);
12312       XSRETURN(1);
12313     }
12314     inp = inspec;
12315   }
12316   else {
12317     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12318       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12319       ST(0) = &PL_sv_no;
12320       Safefree(inspec);
12321       XSRETURN(1);
12322     }
12323   }
12324   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12325   Newx(outspec, VMS_MAXRSS, char);
12326   if (SvTYPE(mysv) == SVt_PVGV) {
12327     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12328       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12329       ST(0) = &PL_sv_no;
12330       Safefree(inspec);
12331       Safefree(outspec);
12332       XSRETURN(1);
12333     }
12334     outp = outspec;
12335   }
12336   else {
12337     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12338       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12339       ST(0) = &PL_sv_no;
12340       Safefree(inspec);
12341       Safefree(outspec);
12342       XSRETURN(1);
12343     }
12344   }
12345   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12346
12347   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12348   Safefree(inspec);
12349   Safefree(outspec);
12350   XSRETURN(1);
12351 }
12352
12353 /* The mod2fname is limited to shorter filenames by design, so it should
12354  * not be modified to support longer EFS pathnames
12355  */
12356 void
12357 mod2fname(pTHX_ CV *cv)
12358 {
12359   dXSARGS;
12360   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12361        workbuff[NAM$C_MAXRSS*1 + 1];
12362   int total_namelen = 3, counter, num_entries;
12363   /* ODS-5 ups this, but we want to be consistent, so... */
12364   int max_name_len = 39;
12365   AV *in_array = (AV *)SvRV(ST(0));
12366
12367   num_entries = av_len(in_array);
12368
12369   /* All the names start with PL_. */
12370   strcpy(ultimate_name, "PL_");
12371
12372   /* Clean up our working buffer */
12373   Zero(work_name, sizeof(work_name), char);
12374
12375   /* Run through the entries and build up a working name */
12376   for(counter = 0; counter <= num_entries; counter++) {
12377     /* If it's not the first name then tack on a __ */
12378     if (counter) {
12379       strcat(work_name, "__");
12380     }
12381     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
12382                            PL_na));
12383   }
12384
12385   /* Check to see if we actually have to bother...*/
12386   if (strlen(work_name) + 3 <= max_name_len) {
12387     strcat(ultimate_name, work_name);
12388   } else {
12389     /* It's too darned big, so we need to go strip. We use the same */
12390     /* algorithm as xsubpp does. First, strip out doubled __ */
12391     char *source, *dest, last;
12392     dest = workbuff;
12393     last = 0;
12394     for (source = work_name; *source; source++) {
12395       if (last == *source && last == '_') {
12396         continue;
12397       }
12398       *dest++ = *source;
12399       last = *source;
12400     }
12401     /* Go put it back */
12402     strcpy(work_name, workbuff);
12403     /* Is it still too big? */
12404     if (strlen(work_name) + 3 > max_name_len) {
12405       /* Strip duplicate letters */
12406       last = 0;
12407       dest = workbuff;
12408       for (source = work_name; *source; source++) {
12409         if (last == toupper(*source)) {
12410         continue;
12411         }
12412         *dest++ = *source;
12413         last = toupper(*source);
12414       }
12415       strcpy(work_name, workbuff);
12416     }
12417
12418     /* Is it *still* too big? */
12419     if (strlen(work_name) + 3 > max_name_len) {
12420       /* Too bad, we truncate */
12421       work_name[max_name_len - 2] = 0;
12422     }
12423     strcat(ultimate_name, work_name);
12424   }
12425
12426   /* Okay, return it */
12427   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12428   XSRETURN(1);
12429 }
12430
12431 void
12432 hushexit_fromperl(pTHX_ CV *cv)
12433 {
12434     dXSARGS;
12435
12436     if (items > 0) {
12437         VMSISH_HUSHED = SvTRUE(ST(0));
12438     }
12439     ST(0) = boolSV(VMSISH_HUSHED);
12440     XSRETURN(1);
12441 }
12442
12443
12444 PerlIO *
12445 Perl_vms_start_glob
12446    (pTHX_ SV *tmpglob,
12447     IO *io)
12448 {
12449     PerlIO *fp;
12450     struct vs_str_st *rslt;
12451     char *vmsspec;
12452     char *rstr;
12453     char *begin, *cp;
12454     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12455     PerlIO *tmpfp;
12456     STRLEN i;
12457     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12458     struct dsc$descriptor_vs rsdsc;
12459     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12460     unsigned long hasver = 0, isunix = 0;
12461     unsigned long int lff_flags = 0;
12462     int rms_sts;
12463
12464 #ifdef VMS_LONGNAME_SUPPORT
12465     lff_flags = LIB$M_FIL_LONG_NAMES;
12466 #endif
12467     /* The Newx macro will not allow me to assign a smaller array
12468      * to the rslt pointer, so we will assign it to the begin char pointer
12469      * and then copy the value into the rslt pointer.
12470      */
12471     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12472     rslt = (struct vs_str_st *)begin;
12473     rslt->length = 0;
12474     rstr = &rslt->str[0];
12475     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12476     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12477     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12478     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12479
12480     Newx(vmsspec, VMS_MAXRSS, char);
12481
12482         /* We could find out if there's an explicit dev/dir or version
12483            by peeking into lib$find_file's internal context at
12484            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12485            but that's unsupported, so I don't want to do it now and
12486            have it bite someone in the future. */
12487         /* Fix-me: vms_split_path() is the only way to do this, the
12488            existing method will fail with many legal EFS or UNIX specifications
12489          */
12490
12491     cp = SvPV(tmpglob,i);
12492
12493     for (; i; i--) {
12494         if (cp[i] == ';') hasver = 1;
12495         if (cp[i] == '.') {
12496             if (sts) hasver = 1;
12497             else sts = 1;
12498         }
12499         if (cp[i] == '/') {
12500             hasdir = isunix = 1;
12501             break;
12502         }
12503         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12504             hasdir = 1;
12505             break;
12506         }
12507     }
12508     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12509         int found = 0;
12510         Stat_t st;
12511         int stat_sts;
12512         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12513         if (!stat_sts && S_ISDIR(st.st_mode)) {
12514             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12515             ok = (wilddsc.dsc$a_pointer != NULL);
12516             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12517             hasdir = 1;
12518         }
12519         else {
12520             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12521             ok = (wilddsc.dsc$a_pointer != NULL);
12522         }
12523         if (ok)
12524             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12525
12526         /* If not extended character set, replace ? with % */
12527         /* With extended character set, ? is a wildcard single character */
12528         if (!decc_efs_case_preserve) {
12529             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12530                 if (*cp == '?') *cp = '%';
12531         }
12532         sts = SS$_NORMAL;
12533         while (ok && $VMS_STATUS_SUCCESS(sts)) {
12534          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12535          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12536
12537             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12538                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
12539             if (!$VMS_STATUS_SUCCESS(sts))
12540                 break;
12541
12542             found++;
12543
12544             /* with varying string, 1st word of buffer contains result length */
12545             rstr[rslt->length] = '\0';
12546
12547              /* Find where all the components are */
12548              v_sts = vms_split_path
12549                        (rstr,
12550                         &v_spec,
12551                         &v_len,
12552                         &r_spec,
12553                         &r_len,
12554                         &d_spec,
12555                         &d_len,
12556                         &n_spec,
12557                         &n_len,
12558                         &e_spec,
12559                         &e_len,
12560                         &vs_spec,
12561                         &vs_len);
12562
12563             /* If no version on input, truncate the version on output */
12564             if (!hasver && (vs_len > 0)) {
12565                 *vs_spec = '\0';
12566                 vs_len = 0;
12567
12568                 /* No version & a null extension on UNIX handling */
12569                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12570                     e_len = 0;
12571                     *e_spec = '\0';
12572                 }
12573             }
12574
12575             if (!decc_efs_case_preserve) {
12576                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12577             }
12578
12579             if (hasdir) {
12580                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12581                 begin = rstr;
12582             }
12583             else {
12584                 /* Start with the name */
12585                 begin = n_spec;
12586             }
12587             strcat(begin,"\n");
12588             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12589         }
12590         if (cxt) (void)lib$find_file_end(&cxt);
12591
12592         if (!found) {
12593             /* Be POSIXish: return the input pattern when no matches */
12594             begin = SvPVX(tmpglob);
12595             strcat(begin,"\n");
12596             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12597         }
12598
12599         if (ok && sts != RMS$_NMF &&
12600             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12601         if (!ok) {
12602             if (!(sts & 1)) {
12603                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12604             }
12605             PerlIO_close(tmpfp);
12606             fp = NULL;
12607         }
12608         else {
12609             PerlIO_rewind(tmpfp);
12610             IoTYPE(io) = IoTYPE_RDONLY;
12611             IoIFP(io) = fp = tmpfp;
12612             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12613         }
12614     }
12615     Safefree(vmsspec);
12616     Safefree(rslt);
12617     return fp;
12618 }
12619
12620
12621 #ifdef HAS_SYMLINK
12622 static char *
12623 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12624                    const int *utf8_fl);
12625
12626 void
12627 vms_realpath_fromperl(pTHX_ CV *cv)
12628 {
12629   dXSARGS;
12630   char *fspec, *rslt_spec, *rslt;
12631   STRLEN n_a;
12632
12633   if (!items || items != 1)
12634     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12635
12636   fspec = SvPV(ST(0),n_a);
12637   if (!fspec || !*fspec) XSRETURN_UNDEF;
12638
12639   Newx(rslt_spec, VMS_MAXRSS + 1, char);
12640   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12641   ST(0) = sv_newmortal();
12642   if (rslt != NULL)
12643     sv_usepvn(ST(0),rslt,strlen(rslt));
12644   else
12645     Safefree(rslt_spec);
12646   XSRETURN(1);
12647 }
12648 #endif
12649
12650 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12651 int do_vms_case_tolerant(void);
12652
12653 void
12654 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12655 {
12656   dXSARGS;
12657   ST(0) = boolSV(do_vms_case_tolerant());
12658   XSRETURN(1);
12659 }
12660 #endif
12661
12662 void
12663 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12664                           struct interp_intern *dst)
12665 {
12666     memcpy(dst,src,sizeof(struct interp_intern));
12667 }
12668
12669 void
12670 Perl_sys_intern_clear(pTHX)
12671 {
12672 }
12673
12674 void
12675 Perl_sys_intern_init(pTHX)
12676 {
12677     unsigned int ix = RAND_MAX;
12678     double x;
12679
12680     VMSISH_HUSHED = 0;
12681
12682     /* fix me later to track running under GNV */
12683     /* this allows some limited testing */
12684     MY_POSIX_EXIT = decc_filename_unix_report;
12685
12686     x = (float)ix;
12687     MY_INV_RAND_MAX = 1./x;
12688 }
12689
12690 void
12691 init_os_extras(void)
12692 {
12693   dTHX;
12694   char* file = __FILE__;
12695   if (decc_disable_to_vms_logname_translation) {
12696     no_translate_barewords = TRUE;
12697   } else {
12698     no_translate_barewords = FALSE;
12699   }
12700
12701   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12702   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12703   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12704   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12705   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12706   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12707   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12708   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12709   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12710   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12711   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12712 #ifdef HAS_SYMLINK
12713   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12714 #endif
12715 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12716   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12717 #endif
12718
12719   store_pipelocs(aTHX);         /* will redo any earlier attempts */
12720
12721   return;
12722 }
12723
12724 #ifdef HAS_SYMLINK
12725
12726 #if __CRTL_VER == 80200000
12727 /* This missed getting in to the DECC SDK for 8.2 */
12728 char *realpath(const char *file_name, char * resolved_name, ...);
12729 #endif
12730
12731 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12732 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12733  * The perl fallback routine to provide realpath() is not as efficient
12734  * on OpenVMS.
12735  */
12736 static char *
12737 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
12738                    const int *utf8_fl)
12739 {
12740     return realpath(filespec, outbuf);
12741 }
12742
12743 /*}}}*/
12744 /* External entry points */
12745 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12746 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12747 #else
12748 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12749 { return NULL; }
12750 #endif
12751
12752
12753 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12754 /* case_tolerant */
12755
12756 /*{{{int do_vms_case_tolerant(void)*/
12757 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12758  * controlled by a process setting.
12759  */
12760 int do_vms_case_tolerant(void)
12761 {
12762     return vms_process_case_tolerant;
12763 }
12764 /*}}}*/
12765 /* External entry points */
12766 int Perl_vms_case_tolerant(void)
12767 { return do_vms_case_tolerant(); }
12768 #else
12769 int Perl_vms_case_tolerant(void)
12770 { return vms_process_case_tolerant; }
12771 #endif
12772
12773
12774  /* Start of DECC RTL Feature handling */
12775
12776 static int sys_trnlnm
12777    (const char * logname,
12778     char * value,
12779     int value_len)
12780 {
12781     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12782     const unsigned long attr = LNM$M_CASE_BLIND;
12783     struct dsc$descriptor_s name_dsc;
12784     int status;
12785     unsigned short result;
12786     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12787                                 {0, 0, 0, 0}};
12788
12789     name_dsc.dsc$w_length = strlen(logname);
12790     name_dsc.dsc$a_pointer = (char *)logname;
12791     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12792     name_dsc.dsc$b_class = DSC$K_CLASS_S;
12793
12794     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12795
12796     if ($VMS_STATUS_SUCCESS(status)) {
12797
12798          /* Null terminate and return the string */
12799         /*--------------------------------------*/
12800         value[result] = 0;
12801     }
12802
12803     return status;
12804 }
12805
12806 static int sys_crelnm
12807    (const char * logname,
12808     const char * value)
12809 {
12810     int ret_val;
12811     const char * proc_table = "LNM$PROCESS_TABLE";
12812     struct dsc$descriptor_s proc_table_dsc;
12813     struct dsc$descriptor_s logname_dsc;
12814     struct itmlst_3 item_list[2];
12815
12816     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12817     proc_table_dsc.dsc$w_length = strlen(proc_table);
12818     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12819     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12820
12821     logname_dsc.dsc$a_pointer = (char *) logname;
12822     logname_dsc.dsc$w_length = strlen(logname);
12823     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12824     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12825
12826     item_list[0].buflen = strlen(value);
12827     item_list[0].itmcode = LNM$_STRING;
12828     item_list[0].bufadr = (char *)value;
12829     item_list[0].retlen = NULL;
12830
12831     item_list[1].buflen = 0;
12832     item_list[1].itmcode = 0;
12833
12834     ret_val = sys$crelnm
12835                        (NULL,
12836                         (const struct dsc$descriptor_s *)&proc_table_dsc,
12837                         (const struct dsc$descriptor_s *)&logname_dsc,
12838                         NULL,
12839                         (const struct item_list_3 *) item_list);
12840
12841     return ret_val;
12842 }
12843
12844 /* C RTL Feature settings */
12845
12846 static int set_features
12847    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12848     int (* cli_routine)(void),  /* Not documented */
12849     void *image_info)           /* Not documented */
12850 {
12851     int status;
12852     int s;
12853     int dflt;
12854     char* str;
12855     char val_str[10];
12856 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12857     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12858     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12859     unsigned long case_perm;
12860     unsigned long case_image;
12861 #endif
12862
12863     /* Allow an exception to bring Perl into the VMS debugger */
12864     vms_debug_on_exception = 0;
12865     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12866     if ($VMS_STATUS_SUCCESS(status)) {
12867        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12868          vms_debug_on_exception = 1;
12869        else
12870          vms_debug_on_exception = 0;
12871     }
12872
12873     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
12874     vms_vtf7_filenames = 0;
12875     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12876     if ($VMS_STATUS_SUCCESS(status)) {
12877        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12878          vms_vtf7_filenames = 1;
12879        else
12880          vms_vtf7_filenames = 0;
12881     }
12882
12883
12884     /* unlink all versions on unlink() or rename() */
12885     vms_vtf7_filenames = 0;
12886     status = sys_trnlnm
12887         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
12888     if ($VMS_STATUS_SUCCESS(status)) {
12889        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12890          vms_unlink_all_versions = 1;
12891        else
12892          vms_unlink_all_versions = 0;
12893     }
12894
12895     /* Dectect running under GNV Bash or other UNIX like shell */
12896 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12897     gnv_unix_shell = 0;
12898     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12899     if ($VMS_STATUS_SUCCESS(status)) {
12900        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12901          gnv_unix_shell = 1;
12902          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12903          set_feature_default("DECC$EFS_CHARSET", 1);
12904          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12905          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12906          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12907          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12908          vms_unlink_all_versions = 1;
12909        }
12910        else
12911          gnv_unix_shell = 0;
12912     }
12913 #endif
12914
12915     /* hacks to see if known bugs are still present for testing */
12916
12917     /* Readdir is returning filenames in VMS syntax always */
12918     decc_bug_readdir_efs1 = 1;
12919     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12920     if ($VMS_STATUS_SUCCESS(status)) {
12921        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12922          decc_bug_readdir_efs1 = 1;
12923        else
12924          decc_bug_readdir_efs1 = 0;
12925     }
12926
12927     /* PCP mode requires creating /dev/null special device file */
12928     decc_bug_devnull = 0;
12929     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12930     if ($VMS_STATUS_SUCCESS(status)) {
12931        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12932           decc_bug_devnull = 1;
12933        else
12934           decc_bug_devnull = 0;
12935     }
12936
12937     /* fgetname returning a VMS name in UNIX mode */
12938     decc_bug_fgetname = 1;
12939     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12940     if ($VMS_STATUS_SUCCESS(status)) {
12941       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12942         decc_bug_fgetname = 1;
12943       else
12944         decc_bug_fgetname = 0;
12945     }
12946
12947     /* UNIX directory names with no paths are broken in a lot of places */
12948     decc_dir_barename = 1;
12949     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12950     if ($VMS_STATUS_SUCCESS(status)) {
12951       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12952         decc_dir_barename = 1;
12953       else
12954         decc_dir_barename = 0;
12955     }
12956
12957 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12958     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12959     if (s >= 0) {
12960         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12961         if (decc_disable_to_vms_logname_translation < 0)
12962             decc_disable_to_vms_logname_translation = 0;
12963     }
12964
12965     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12966     if (s >= 0) {
12967         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12968         if (decc_efs_case_preserve < 0)
12969             decc_efs_case_preserve = 0;
12970     }
12971
12972     s = decc$feature_get_index("DECC$EFS_CHARSET");
12973     if (s >= 0) {
12974         decc_efs_charset = decc$feature_get_value(s, 1);
12975         if (decc_efs_charset < 0)
12976             decc_efs_charset = 0;
12977     }
12978
12979     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12980     if (s >= 0) {
12981         decc_filename_unix_report = decc$feature_get_value(s, 1);
12982         if (decc_filename_unix_report > 0)
12983             decc_filename_unix_report = 1;
12984         else
12985             decc_filename_unix_report = 0;
12986     }
12987
12988     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12989     if (s >= 0) {
12990         decc_filename_unix_only = decc$feature_get_value(s, 1);
12991         if (decc_filename_unix_only > 0) {
12992             decc_filename_unix_only = 1;
12993         }
12994         else {
12995             decc_filename_unix_only = 0;
12996         }
12997     }
12998
12999     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13000     if (s >= 0) {
13001         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13002         if (decc_filename_unix_no_version < 0)
13003             decc_filename_unix_no_version = 0;
13004     }
13005
13006     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13007     if (s >= 0) {
13008         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13009         if (decc_readdir_dropdotnotype < 0)
13010             decc_readdir_dropdotnotype = 0;
13011     }
13012
13013     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13014     if ($VMS_STATUS_SUCCESS(status)) {
13015         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13016         if (s >= 0) {
13017             dflt = decc$feature_get_value(s, 4);
13018             if (dflt > 0) {
13019                 decc_disable_posix_root = decc$feature_get_value(s, 1);
13020                 if (decc_disable_posix_root <= 0) {
13021                     decc$feature_set_value(s, 1, 1);
13022                     decc_disable_posix_root = 1;
13023                 }
13024             }
13025             else {
13026                 /* Traditionally Perl assumes this is off */
13027                 decc_disable_posix_root = 1;
13028                 decc$feature_set_value(s, 1, 1);
13029             }
13030         }
13031     }
13032
13033 #if __CRTL_VER >= 80200000
13034     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13035     if (s >= 0) {
13036         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13037         if (decc_posix_compliant_pathnames < 0)
13038             decc_posix_compliant_pathnames = 0;
13039         if (decc_posix_compliant_pathnames > 4)
13040             decc_posix_compliant_pathnames = 0;
13041     }
13042
13043 #endif
13044 #else
13045     status = sys_trnlnm
13046         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13047     if ($VMS_STATUS_SUCCESS(status)) {
13048         val_str[0] = _toupper(val_str[0]);
13049         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13050            decc_disable_to_vms_logname_translation = 1;
13051         }
13052     }
13053
13054 #ifndef __VAX
13055     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13056     if ($VMS_STATUS_SUCCESS(status)) {
13057         val_str[0] = _toupper(val_str[0]);
13058         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13059            decc_efs_case_preserve = 1;
13060         }
13061     }
13062 #endif
13063
13064     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13065     if ($VMS_STATUS_SUCCESS(status)) {
13066         val_str[0] = _toupper(val_str[0]);
13067         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13068            decc_filename_unix_report = 1;
13069         }
13070     }
13071     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13072     if ($VMS_STATUS_SUCCESS(status)) {
13073         val_str[0] = _toupper(val_str[0]);
13074         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13075            decc_filename_unix_only = 1;
13076            decc_filename_unix_report = 1;
13077         }
13078     }
13079     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13080     if ($VMS_STATUS_SUCCESS(status)) {
13081         val_str[0] = _toupper(val_str[0]);
13082         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13083            decc_filename_unix_no_version = 1;
13084         }
13085     }
13086     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13087     if ($VMS_STATUS_SUCCESS(status)) {
13088         val_str[0] = _toupper(val_str[0]);
13089         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13090            decc_readdir_dropdotnotype = 1;
13091         }
13092     }
13093 #endif
13094
13095 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13096
13097      /* Report true case tolerance */
13098     /*----------------------------*/
13099     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13100     if (!$VMS_STATUS_SUCCESS(status))
13101         case_perm = PPROP$K_CASE_BLIND;
13102     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13103     if (!$VMS_STATUS_SUCCESS(status))
13104         case_image = PPROP$K_CASE_BLIND;
13105     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13106         (case_image == PPROP$K_CASE_SENSITIVE))
13107         vms_process_case_tolerant = 0;
13108
13109 #endif
13110
13111
13112     /* CRTL can be initialized past this point, but not before. */
13113 /*    DECC$CRTL_INIT(); */
13114
13115     return SS$_NORMAL;
13116 }
13117
13118 #ifdef __DECC
13119 #pragma nostandard
13120 #pragma extern_model save
13121 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13122         const __align (LONGWORD) int spare[8] = {0};
13123
13124 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13125 #if __DECC_VER >= 60560002
13126 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13127 #else
13128 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13129 #endif
13130 #endif /* __DECC */
13131
13132 const long vms_cc_features = (const long)set_features;
13133
13134 /*
13135 ** Force a reference to LIB$INITIALIZE to ensure it
13136 ** exists in the image.
13137 */
13138 int lib$initialize(void);
13139 #ifdef __DECC
13140 #pragma extern_model strict_refdef
13141 #endif
13142     int lib_init_ref = (int) lib$initialize;
13143
13144 #ifdef __DECC
13145 #pragma extern_model restore
13146 #pragma standard
13147 #endif
13148
13149 /*  End of vms.c */