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 <descrip.h>
  21 #include <devdef.h>
  22 #include <dvidef.h>
  23 #include <fibdef.h>
  24 #include <float.h>
  25 #include <fscndef.h>
  26 #include <iodef.h>
  27 #include <jpidef.h>
  28 #include <kgbdef.h>
  29 #include <libclidef.h>
  30 #include <libdef.h>
  31 #include <lib$routines.h>
  32 #include <lnmdef.h>
  33 #include <msgdef.h>
  34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  35 #include <ppropdef.h>
  36 #endif
  37 #include <prvdef.h>
  38 #include <psldef.h>
  39 #include <rms.h>
  40 #include <shrdef.h>
  41 #include <ssdef.h>
  42 #include <starlet.h>
  43 #include <strdef.h>
  44 #include <str$routines.h>
  45 #include <syidef.h>
  46 #include <uaidef.h>
  47 #include <uicdef.h>
  48 #include <stsdef.h>
  49 #include <rmsdef.h>
  50
  51 /* Set the maximum filespec size here as it is larger for EFS file
  52  * specifications.
  53  * Not fully implemented at this time because the larger size
  54  * will likely impact the stack local storage requirements of
  55  * threaded code, and probably cause hard to diagnose failures.
  56  * To implement the larger sizes, all places where filename
  57  * storage is put on the stack need to be changed to use
  58  * New()/SafeFree() instead.
  59  */
  60 #ifndef __VAX
  61 #ifndef VMS_MAXRSS
  62 #ifdef NAML$C_MAXRSS
  63 #define VMS_MAXRSS (NAML$C_MAXRSS+1)
  64 #ifndef VMS_LONGNAME_SUPPORT
  65 #define VMS_LONGNAME_SUPPORT 1
  66 #endif /* VMS_LONGNAME_SUPPORT */
  67 #endif /* NAML$C_MAXRSS */
  68 #endif /* VMS_MAXRSS */
  69 #endif
  70
  71 /* temporary hack until support is complete */
  72 #ifdef VMS_LONGNAME_SUPPORT
  73 #undef VMS_LONGNAME_SUPPORT
  74 #undef VMS_MAXRSS
  75 #endif
  76 /* end of temporary hack until support is complete */
  77
  78 #ifndef VMS_MAXRSS
  79 #define VMS_MAXRSS (NAM$C_MAXRSS + 1)
  80 #endif
  81
  82 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  83 int   decc$feature_get_index(const char *name);
  84 char* decc$feature_get_name(int index);
  85 int   decc$feature_get_value(int index, int mode);
  86 int   decc$feature_set_value(int index, int mode, int value);
  87 #else
  88 #include <unixlib.h>
  89 #endif
  90
  91 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  92
  93 static int set_feature_default(const char *name, int value)
  94 {
  95     int status;
  96     int index;
  97
  98     index = decc$feature_get_index(name);
  99
 100     status = decc$feature_set_value(index, 1, value);
 101     if (index == -1 || (status == -1)) {
 102       return -1;
 103     }
 104
 105     status = decc$feature_get_value(index, 1);
 106     if (status != value) {
 107       return -1;
 108     }
 109
 110 return 0;
 111 }
 112 #endif
 113
 114 /* Older versions of ssdef.h don't have these */
 115 #ifndef SS$_INVFILFOROP
 116 #  define SS$_INVFILFOROP 3930
 117 #endif
 118 #ifndef SS$_NOSUCHOBJECT
 119 #  define SS$_NOSUCHOBJECT 2696
 120 #endif
 121
 122 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 123 #define PERLIO_NOT_STDIO 0
 124
 125 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 126  * code below needs to get to the underlying CRTL routines. */
 127 #define DONT_MASK_RTL_CALLS
 128 #include "EXTERN.h"
 129 #include "perl.h"
 130 #include "XSUB.h"
 131 /* Anticipating future expansion in lexical warnings . . . */
 132 #ifndef WARN_INTERNAL
 133 #  define WARN_INTERNAL WARN_MISC
 134 #endif
 135
 136 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 137 #  define RTL_USES_UTC 1
 138 #endif
 139
 140
 141 /* gcc's header files don't #define direct access macros
 142  * corresponding to VAXC's variant structs */
 143 #ifdef __GNUC__
 144 #  define uic$v_format uic$r_uic_form.uic$v_format
 145 #  define uic$v_group uic$r_uic_form.uic$v_group
 146 #  define uic$v_member uic$r_uic_form.uic$v_member
 147 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 148 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 149 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 150 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 151 #endif
 152
 153 #if defined(NEED_AN_H_ERRNO)
 154 dEXT int h_errno;
 155 #endif
 156
 157 #ifdef __DECC
 158 #pragma message disable pragma
 159 #pragma member_alignment save
 160 #pragma nomember_alignment longword
 161 #pragma message save
 162 #pragma message disable misalgndmem
 163 #endif
 164 struct itmlst_3 {
 165   unsigned short int buflen;
 166   unsigned short int itmcode;
 167   void *bufadr;
 168   unsigned short int *retlen;
 169 };
 170
 171 struct filescan_itmlst_2 {
 172     unsigned short length;
 173     unsigned short itmcode;
 174     char * component;
 175 };
 176
 177 struct vs_str_st {
 178     unsigned short length;
 179     char str[65536];
 180 };
 181
 182 #ifdef __DECC
 183 #pragma message restore
 184 #pragma member_alignment restore
 185 #endif
 186
 187 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
 188 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
 189 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
 190 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
 191 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
 192 #define do_vms_realpath(a,b)            mp_do_vms_realpath(aTHX_ a,b)
 193 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
 194 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
 195 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 196 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 197 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 198
 199 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
 200 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
 201 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
 202 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
 203
 204 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 205 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 206
 207 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 208  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 209  * the Perl facility.
 210  */
 211 #define PERL_LNM_MAX_ITER 10
 212
 213   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 214 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 215 #define MAX_DCL_SYMBOL          (8192)
 216 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 217 #else
 218 #define MAX_DCL_SYMBOL          (1024)
 219 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 220 #endif
 221
 222 static char *__mystrtolower(char *str)
 223 {
 224   if (str) for (; *str; ++str) *str= tolower(*str);
 225   return str;
 226 }
 227
 228 static struct dsc$descriptor_s fildevdsc =
 229   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 230 static struct dsc$descriptor_s crtlenvdsc =
 231   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 232 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 233 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 234 static struct dsc$descriptor_s **env_tables = defenv;
 235 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 236
 237 /* True if we shouldn't treat barewords as logicals during directory */
 238 /* munching */
 239 static int no_translate_barewords;
 240
 241 #ifndef RTL_USES_UTC
 242 static int tz_updated = 1;
 243 #endif
 244
 245 /* DECC Features that may need to affect how Perl interprets
 246  * displays filename information
 247  */
 248 static int decc_disable_to_vms_logname_translation = 1;
 249 static int decc_disable_posix_root = 1;
 250 int decc_efs_case_preserve = 0;
 251 static int decc_efs_charset = 0;
 252 static int decc_filename_unix_no_version = 0;
 253 static int decc_filename_unix_only = 0;
 254 int decc_filename_unix_report = 0;
 255 int decc_posix_compliant_pathnames = 0;
 256 int decc_readdir_dropdotnotype = 0;
 257 static int vms_process_case_tolerant = 1;
 258
 259 /* bug workarounds if needed */
 260 int decc_bug_readdir_efs1 = 0;
 261 int decc_bug_devnull = 1;
 262 int decc_bug_fgetname = 0;
 263 int decc_dir_barename = 0;
 264
 265 static int vms_debug_on_exception = 0;
 266
 267 /* Is this a UNIX file specification?
 268  *   No longer a simple check with EFS file specs
 269  *   For now, not a full check, but need to
 270  *   handle POSIX ^UP^ specifications
 271  *   Fixing to handle ^/ cases would require
 272  *   changes to many other conversion routines.
 273  */
 274
 275 static int is_unix_filespec(const char *path)
 276 {
 277 int ret_val;
 278 const char * pch1;
 279
 280     ret_val = 0;
 281     if (strncmp(path,"\"^UP^",5) != 0) {
 282         pch1 = strchr(path, '/');
 283         if (pch1 != NULL)
 284             ret_val = 1;
 285         else {
 286
 287             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 288             if (decc_filename_unix_report || decc_filename_unix_only) {
 289             if (strcmp(path,".") == 0)
 290                 ret_val = 1;
 291             }
 292         }
 293     }
 294     return ret_val;
 295 }
 296
 297 /* This handles the expansion of a '^' prefix to the proper character
 298  * in a UNIX file specification.
 299  *
 300  * The output count variable contains the number of characters added
 301  * to the output string.
 302  *
 303  * The return value is the number of characters read from the input
 304  * string
 305  */
 306 static int copy_expand_vms_filename_escape
 307   (char *outspec, const char *inspec, int *output_cnt)
 308 {
 309 int count;
 310 int scnt;
 311
 312     count = 0;
 313     *output_cnt = 0;
 314     if (*inspec == '^') {
 315         inspec++;
 316         switch (*inspec) {
 317         case '.':
 318             /* Non trailing dots should just be passed through */
 319             *outspec = *inspec;
 320             count++;
 321             (*output_cnt)++;
 322             break;
 323         case '_': /* space */
 324             *outspec = ' ';
 325             inspec++;
 326             count++;
 327             (*output_cnt)++;
 328             break;
 329         case 'U': /* Unicode */
 330             inspec++;
 331             count++;
 332             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 333             if (scnt == 4) {
 334                 unsigned int c1, c2;
 335                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 336                 outspec[0] == c1 & 0xff;
 337                 outspec[1] == c2 & 0xff;
 338                 if (scnt > 1) {
 339                     (*output_cnt) += 2;
 340                     count += 4;
 341                 }
 342             }
 343             else {
 344                 /* Error - do best we can to continue */
 345                 *outspec = 'U';
 346                 outspec++;
 347                 (*output_cnt++);
 348                 *outspec = *inspec;
 349                 count++;
 350                 (*output_cnt++);
 351             }
 352             break;
 353         default:
 354             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 355             if (scnt == 2) {
 356                 /* Hex encoded */
 357                 unsigned int c1;
 358                 scnt = sscanf(inspec, "%2x", &c1);
 359                 outspec[0] = c1 & 0xff;
 360                 if (scnt > 0) {
 361                     (*output_cnt++);
 362                     count += 2;
 363                 }
 364             }
 365             else {
 366                 *outspec = *inspec;
 367                 count++;
 368                 (*output_cnt++);
 369             }
 370         }
 371     }
 372     else {
 373         *outspec = *inspec;
 374         count++;
 375         (*output_cnt)++;
 376     }
 377     return count;
 378 }
 379
 380
 381 int SYS$FILESCAN
 382    (const struct dsc$descriptor_s * srcstr,
 383     struct filescan_itmlst_2 * valuelist,
 384     unsigned long * fldflags,
 385     struct dsc$descriptor_s *auxout,
 386     unsigned short * retlen);
 387
 388 /* vms_split_path - Verify that the input file specification is a
 389  * VMS format file specification, and provide pointers to the components of
 390  * it.  With EFS format filenames, this is virtually the only way to
 391  * parse a VMS path specification into components.
 392  *
 393  * If the sum of the components do not add up to the length of the
 394  * string, then the passed file specification is probably a UNIX style
 395  * path.
 396  */
 397 static int vms_split_path
 398    (pTHX_ const char * path,
 399     char * * volume,
 400     int * vol_len,
 401     char * * root,
 402     int * root_len,
 403     char * * dir,
 404     int * dir_len,
 405     char * * name,
 406     int * name_len,
 407     char * * ext,
 408     int * ext_len,
 409     char * * version,
 410     int * ver_len)
 411 {
 412 struct dsc$descriptor path_desc;
 413 int status;
 414 unsigned long flags;
 415 int ret_stat;
 416 struct filescan_itmlst_2 item_list[9];
 417 const int filespec = 0;
 418 const int nodespec = 1;
 419 const int devspec = 2;
 420 const int rootspec = 3;
 421 const int dirspec = 4;
 422 const int namespec = 5;
 423 const int typespec = 6;
 424 const int verspec = 7;
 425
 426     /* Assume the worst for an easy exit */
 427     ret_stat = -1;
 428     *volume = NULL;
 429     *vol_len = 0;
 430     *root = NULL;
 431     *root_len = 0;
 432     *dir = NULL;
 433     *dir_len;
 434     *name = NULL;
 435     *name_len = 0;
 436     *ext = NULL;
 437     *ext_len = 0;
 438     *version = NULL;
 439     *ver_len = 0;
 440
 441     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 442     path_desc.dsc$w_length = strlen(path);
 443     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 444     path_desc.dsc$b_class = DSC$K_CLASS_S;
 445
 446     /* Get the total length, if it is shorter than the string passed
 447      * then this was probably not a VMS formatted file specification
 448      */
 449     item_list[filespec].itmcode = FSCN$_FILESPEC;
 450     item_list[filespec].length = 0;
 451     item_list[filespec].component = NULL;
 452
 453     /* If the node is present, then it gets considered as part of the
 454      * volume name to hopefully make things simple.
 455      */
 456     item_list[nodespec].itmcode = FSCN$_NODE;
 457     item_list[nodespec].length = 0;
 458     item_list[nodespec].component = NULL;
 459
 460     item_list[devspec].itmcode = FSCN$_DEVICE;
 461     item_list[devspec].length = 0;
 462     item_list[devspec].component = NULL;
 463
 464     /* root is a special case,  adding it to either the directory or
 465      * the device components will probalby complicate things for the
 466      * callers of this routine, so leave it separate.
 467      */
 468     item_list[rootspec].itmcode = FSCN$_ROOT;
 469     item_list[rootspec].length = 0;
 470     item_list[rootspec].component = NULL;
 471
 472     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 473     item_list[dirspec].length = 0;
 474     item_list[dirspec].component = NULL;
 475
 476     item_list[namespec].itmcode = FSCN$_NAME;
 477     item_list[namespec].length = 0;
 478     item_list[namespec].component = NULL;
 479
 480     item_list[typespec].itmcode = FSCN$_TYPE;
 481     item_list[typespec].length = 0;
 482     item_list[typespec].component = NULL;
 483
 484     item_list[verspec].itmcode = FSCN$_VERSION;
 485     item_list[verspec].length = 0;
 486     item_list[verspec].component = NULL;
 487
 488     item_list[8].itmcode = 0;
 489     item_list[8].length = 0;
 490     item_list[8].component = NULL;
 491
 492     status = SYS$FILESCAN
 493        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 494         &flags, NULL, NULL);
 495     _ckvmssts(status); /* All failure status values indicate a coding error */
 496
 497     /* If we parsed it successfully these two lengths should be the same */
 498     if (path_desc.dsc$w_length != item_list[filespec].length)
 499         return ret_stat;
 500
 501     /* If we got here, then it is a VMS file specification */
 502     ret_stat = 0;
 503
 504     /* set the volume name */
 505     if (item_list[nodespec].length > 0) {
 506         *volume = item_list[nodespec].component;
 507         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 508     }
 509     else {
 510         *volume = item_list[devspec].component;
 511         *vol_len = item_list[devspec].length;
 512     }
 513
 514     *root = item_list[rootspec].component;
 515     *root_len = item_list[rootspec].length;
 516
 517     *dir = item_list[dirspec].component;
 518     *dir_len = item_list[dirspec].length;
 519
 520     /* Now fun with versions and EFS file specifications
 521      * The parser can not tell the difference when a "." is a version
 522      * delimiter or a part of the file specification.
 523      */
 524     if ((decc_efs_charset) &&
 525         (item_list[verspec].length > 0) &&
 526         (item_list[verspec].component[0] == '.')) {
 527         *name = item_list[namespec].component;
 528         *name_len = item_list[namespec].length + item_list[typespec].length;
 529         *ext = item_list[verspec].component;
 530         *ext_len = item_list[verspec].length;
 531         *version = NULL;
 532         *ver_len = 0;
 533     }
 534     else {
 535         *name = item_list[namespec].component;
 536         *name_len = item_list[namespec].length;
 537         *ext = item_list[typespec].component;
 538         *ext_len = item_list[typespec].length;
 539         *version = item_list[verspec].component;
 540         *ver_len = item_list[verspec].length;
 541     }
 542     return ret_stat;
 543 }
 544
 545
 546 /* my_maxidx
 547  * Routine to retrieve the maximum equivalence index for an input
 548  * logical name.  Some calls to this routine have no knowledge if
 549  * the variable is a logical or not.  So on error we return a max
 550  * index of zero.
 551  */
 552 /*{{{int my_maxidx(const char *lnm) */
 553 static int
 554 my_maxidx(const char *lnm)
 555 {
 556     int status;
 557     int midx;
 558     int attr = LNM$M_CASE_BLIND;
 559     struct dsc$descriptor lnmdsc;
 560     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 561                                 {0, 0, 0, 0}};
 562
 563     lnmdsc.dsc$w_length = strlen(lnm);
 564     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 565     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 566     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 567
 568     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 569     if ((status & 1) == 0)
 570        midx = 0;
 571
 572     return (midx);
 573 }
 574 /*}}}*/
 575
 576 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 577 int
 578 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 579   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 580 {
 581     const char *cp1;
 582     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 583     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 584     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 585     int midx;
 586     unsigned char acmode;
 587     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 588                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 589     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 590                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 591                                  {0, 0, 0, 0}};
 592     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 593 #if defined(PERL_IMPLICIT_CONTEXT)
 594     pTHX = NULL;
 595     if (PL_curinterp) {
 596       aTHX = PERL_GET_INTERP;
 597     } else {
 598       aTHX = NULL;
 599     }
 600 #endif
 601
 602     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 603       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 604     }
 605     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 606       *cp2 = _toupper(*cp1);
 607       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 608         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 609         return 0;
 610       }
 611     }
 612     lnmdsc.dsc$w_length = cp1 - lnm;
 613     lnmdsc.dsc$a_pointer = uplnm;
 614     uplnm[lnmdsc.dsc$w_length] = '\0';
 615     secure = flags & PERL__TRNENV_SECURE;
 616     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 617     if (!tabvec || !*tabvec) tabvec = env_tables;
 618
 619     for (curtab = 0; tabvec[curtab]; curtab++) {
 620       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 621         if (!ivenv && !secure) {
 622           char *eq, *end;
 623           int i;
 624           if (!environ) {
 625             ivenv = 1;
 626             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 627             continue;
 628           }
 629           retsts = SS$_NOLOGNAM;
 630           for (i = 0; environ[i]; i++) {
 631             if ((eq = strchr(environ[i],'=')) &&
 632                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 633                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 634               eq++;
 635               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 636               if (!eqvlen) continue;
 637               retsts = SS$_NORMAL;
 638               break;
 639             }
 640           }
 641           if (retsts != SS$_NOLOGNAM) break;
 642         }
 643       }
 644       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 645                !str$case_blind_compare(&tmpdsc,&clisym)) {
 646         if (!ivsym && !secure) {
 647           unsigned short int deflen = LNM$C_NAMLENGTH;
 648           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 649           /* dynamic dsc to accomodate possible long value */
 650           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 651           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 652           if (retsts & 1) {
 653             if (eqvlen > MAX_DCL_SYMBOL) {
 654               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 655               eqvlen = MAX_DCL_SYMBOL;
 656               /* Special hack--we might be called before the interpreter's */
 657               /* fully initialized, in which case either thr or PL_curcop */
 658               /* might be bogus. We have to check, since ckWARN needs them */
 659               /* both to be valid if running threaded */
 660                 if (ckWARN(WARN_MISC)) {
 661                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 662                 }
 663             }
 664             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 665           }
 666           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 667           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 668           if (retsts == LIB$_NOSUCHSYM) continue;
 669           break;
 670         }
 671       }
 672       else if (!ivlnm) {
 673         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 674           midx = my_maxidx(lnm);
 675           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 676             lnmlst[1].bufadr = cp2;
 677             eqvlen = 0;
 678             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 679             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 680             if (retsts == SS$_NOLOGNAM) break;
 681             /* PPFs have a prefix */
 682             if (
 683 #if INTSIZE == 4
 684                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 685 #endif
 686                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 687                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 688                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 689                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 690                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 691               memmove(eqv,eqv+4,eqvlen-4);
 692               eqvlen -= 4;
 693             }
 694             cp2 += eqvlen;
 695             *cp2 = '\0';
 696           }
 697           if ((retsts == SS$_IVLOGNAM) ||
 698               (retsts == SS$_NOLOGNAM)) { continue; }
 699         }
 700         else {
 701           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 702           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 703           if (retsts == SS$_NOLOGNAM) continue;
 704           eqv[eqvlen] = '\0';
 705         }
 706         eqvlen = strlen(eqv);
 707         break;
 708       }
 709     }
 710     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 711     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 712              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 713              retsts == SS$_NOLOGNAM) {
 714       set_errno(EINVAL);  set_vaxc_errno(retsts);
 715     }
 716     else _ckvmssts(retsts);
 717     return 0;
 718 }  /* end of vmstrnenv */
 719 /*}}}*/
 720
 721 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 722 /* Define as a function so we can access statics. */
 723 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 724 {
 725   return vmstrnenv(lnm,eqv,idx,fildev,
 726 #ifdef SECURE_INTERNAL_GETENV
 727                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 728 #else
 729                    0
 730 #endif
 731                                                                               );
 732 }
 733 /*}}}*/
 734
 735 /* my_getenv
 736  * Note: Uses Perl temp to store result so char * can be returned to
 737  * caller; this pointer will be invalidated at next Perl statement
 738  * transition.
 739  * We define this as a function rather than a macro in terms of my_getenv_len()
 740  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 741  * allocate SVs).
 742  */
 743 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 744 char *
 745 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 746 {
 747     const char *cp1;
 748     static char *__my_getenv_eqv = NULL;
 749     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 750     unsigned long int idx = 0;
 751     int trnsuccess, success, secure, saverr, savvmserr;
 752     int midx, flags;
 753     SV *tmpsv;
 754
 755     midx = my_maxidx(lnm) + 1;
 756
 757     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 758       /* Set up a temporary buffer for the return value; Perl will
 759        * clean it up at the next statement transition */
 760       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 761       if (!tmpsv) return NULL;
 762       eqv = SvPVX(tmpsv);
 763     }
 764     else {
 765       /* Assume no interpreter ==> single thread */
 766       if (__my_getenv_eqv != NULL) {
 767         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 768       }
 769       else {
 770         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 771       }
 772       eqv = __my_getenv_eqv;
 773     }
 774
 775     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 776     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 777       int len;
 778       getcwd(eqv,LNM$C_NAMLENGTH);
 779
 780       len = strlen(eqv);
 781
 782       /* Get rid of "000000/ in rooted filespecs */
 783       if (len > 7) {
 784         char * zeros;
 785         zeros = strstr(eqv, "/000000/");
 786         if (zeros != NULL) {
 787           int mlen;
 788           mlen = len - (zeros - eqv) - 7;
 789           memmove(zeros, &zeros[7], mlen);
 790           len = len - 7;
 791           eqv[len] = '\0';
 792         }
 793       }
 794       return eqv;
 795     }
 796     else {
 797       /* Impose security constraints only if tainting */
 798       if (sys) {
 799         /* Impose security constraints only if tainting */
 800         secure = PL_curinterp ? PL_tainting : will_taint;
 801         saverr = errno;  savvmserr = vaxc$errno;
 802       }
 803       else {
 804         secure = 0;
 805       }
 806
 807       flags =
 808 #ifdef SECURE_INTERNAL_GETENV
 809               secure ? PERL__TRNENV_SECURE : 0
 810 #else
 811               0
 812 #endif
 813       ;
 814
 815       /* For the getenv interface we combine all the equivalence names
 816        * of a search list logical into one value to acquire a maximum
 817        * value length of 255*128 (assuming %ENV is using logicals).
 818        */
 819       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 820
 821       /* If the name contains a semicolon-delimited index, parse it
 822        * off and make sure we only retrieve the equivalence name for
 823        * that index.  */
 824       if ((cp2 = strchr(lnm,';')) != NULL) {
 825         strcpy(uplnm,lnm);
 826         uplnm[cp2-lnm] = '\0';
 827         idx = strtoul(cp2+1,NULL,0);
 828         lnm = uplnm;
 829         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 830       }
 831
 832       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
 833
 834       /* Discard NOLOGNAM on internal calls since we're often looking
 835        * for an optional name, and this "error" often shows up as the
 836        * (bogus) exit status for a die() call later on.  */
 837       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 838       return success ? eqv : Nullch;
 839     }
 840
 841 }  /* end of my_getenv() */
 842 /*}}}*/
 843
 844
 845 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 846 char *
 847 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 848 {
 849     const char *cp1;
 850     char *buf, *cp2;
 851     unsigned long idx = 0;
 852     int midx, flags;
 853     static char *__my_getenv_len_eqv = NULL;
 854     int secure, saverr, savvmserr;
 855     SV *tmpsv;
 856
 857     midx = my_maxidx(lnm) + 1;
 858
 859     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 860       /* Set up a temporary buffer for the return value; Perl will
 861        * clean it up at the next statement transition */
 862       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 863       if (!tmpsv) return NULL;
 864       buf = SvPVX(tmpsv);
 865     }
 866     else {
 867       /* Assume no interpreter ==> single thread */
 868       if (__my_getenv_len_eqv != NULL) {
 869         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 870       }
 871       else {
 872         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 873       }
 874       buf = __my_getenv_len_eqv;
 875     }
 876
 877     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 878     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 879     char * zeros;
 880
 881       getcwd(buf,LNM$C_NAMLENGTH);
 882       *len = strlen(buf);
 883
 884       /* Get rid of "000000/ in rooted filespecs */
 885       if (*len > 7) {
 886       zeros = strstr(buf, "/000000/");
 887       if (zeros != NULL) {
 888         int mlen;
 889         mlen = *len - (zeros - buf) - 7;
 890         memmove(zeros, &zeros[7], mlen);
 891         *len = *len - 7;
 892         buf[*len] = '\0';
 893         }
 894       }
 895       return buf;
 896     }
 897     else {
 898       if (sys) {
 899         /* Impose security constraints only if tainting */
 900         secure = PL_curinterp ? PL_tainting : will_taint;
 901         saverr = errno;  savvmserr = vaxc$errno;
 902       }
 903       else {
 904         secure = 0;
 905       }
 906
 907       flags =
 908 #ifdef SECURE_INTERNAL_GETENV
 909               secure ? PERL__TRNENV_SECURE : 0
 910 #else
 911               0
 912 #endif
 913       ;
 914
 915       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 916
 917       if ((cp2 = strchr(lnm,';')) != NULL) {
 918         strcpy(buf,lnm);
 919         buf[cp2-lnm] = '\0';
 920         idx = strtoul(cp2+1,NULL,0);
 921         lnm = buf;
 922         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 923       }
 924
 925       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
 926
 927       /* Get rid of "000000/ in rooted filespecs */
 928       if (*len > 7) {
 929       char * zeros;
 930         zeros = strstr(buf, "/000000/");
 931         if (zeros != NULL) {
 932           int mlen;
 933           mlen = *len - (zeros - buf) - 7;
 934           memmove(zeros, &zeros[7], mlen);
 935           *len = *len - 7;
 936           buf[*len] = '\0';
 937         }
 938       }
 939
 940       /* Discard NOLOGNAM on internal calls since we're often looking
 941        * for an optional name, and this "error" often shows up as the
 942        * (bogus) exit status for a die() call later on.  */
 943       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 944       return *len ? buf : Nullch;
 945     }
 946
 947 }  /* end of my_getenv_len() */
 948 /*}}}*/
 949
 950 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 951
 952 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 953
 954 /*{{{ void prime_env_iter() */
 955 void
 956 prime_env_iter(void)
 957 /* Fill the %ENV associative array with all logical names we can
 958  * find, in preparation for iterating over it.
 959  */
 960 {
 961   static int primed = 0;
 962   HV *seenhv = NULL, *envhv;
 963   SV *sv = NULL;
 964   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 965   unsigned short int chan;
 966 #ifndef CLI$M_TRUSTED
 967 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 968 #endif
 969   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 970   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 971   long int i;
 972   bool have_sym = FALSE, have_lnm = FALSE;
 973   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 974   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 975   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 976   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 977   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 978 #if defined(PERL_IMPLICIT_CONTEXT)
 979   pTHX;
 980 #endif
 981 #if defined(USE_ITHREADS)
 982   static perl_mutex primenv_mutex;
 983   MUTEX_INIT(&primenv_mutex);
 984 #endif
 985
 986 #if defined(PERL_IMPLICIT_CONTEXT)
 987     /* We jump through these hoops because we can be called at */
 988     /* platform-specific initialization time, which is before anything is */
 989     /* set up--we can't even do a plain dTHX since that relies on the */
 990     /* interpreter structure to be initialized */
 991     if (PL_curinterp) {
 992       aTHX = PERL_GET_INTERP;
 993     } else {
 994       aTHX = NULL;
 995     }
 996 #endif
 997
 998   if (primed || !PL_envgv) return;
 999   MUTEX_LOCK(&primenv_mutex);
1000   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1001   envhv = GvHVn(PL_envgv);
1002   /* Perform a dummy fetch as an lval to insure that the hash table is
1003    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1004   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1005
1006   for (i = 0; env_tables[i]; i++) {
1007      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1008          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1009      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1010   }
1011   if (have_sym || have_lnm) {
1012     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1013     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1014     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1015     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1016   }
1017
1018   for (i--; i >= 0; i--) {
1019     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1020       char *start;
1021       int j;
1022       for (j = 0; environ[j]; j++) {
1023         if (!(start = strchr(environ[j],'='))) {
1024           if (ckWARN(WARN_INTERNAL))
1025             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1026         }
1027         else {
1028           start++;
1029           sv = newSVpv(start,0);
1030           SvTAINTED_on(sv);
1031           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1032         }
1033       }
1034       continue;
1035     }
1036     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1037              !str$case_blind_compare(&tmpdsc,&clisym)) {
1038       strcpy(cmd,"Show Symbol/Global *");
1039       cmddsc.dsc$w_length = 20;
1040       if (env_tables[i]->dsc$w_length == 12 &&
1041           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1042           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1043       flags = defflags | CLI$M_NOLOGNAM;
1044     }
1045     else {
1046       strcpy(cmd,"Show Logical *");
1047       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1048         strcat(cmd," /Table=");
1049         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1050         cmddsc.dsc$w_length = strlen(cmd);
1051       }
1052       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1053       flags = defflags | CLI$M_NOCLISYM;
1054     }
1055
1056     /* Create a new subprocess to execute each command, to exclude the
1057      * remote possibility that someone could subvert a mbx or file used
1058      * to write multiple commands to a single subprocess.
1059      */
1060     do {
1061       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1062                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1063       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1064       defflags &= ~CLI$M_TRUSTED;
1065     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1066     _ckvmssts(retsts);
1067     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1068     if (seenhv) SvREFCNT_dec(seenhv);
1069     seenhv = newHV();
1070     while (1) {
1071       char *cp1, *cp2, *key;
1072       unsigned long int sts, iosb[2], retlen, keylen;
1073       register U32 hash;
1074
1075       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1076       if (sts & 1) sts = iosb[0] & 0xffff;
1077       if (sts == SS$_ENDOFFILE) {
1078         int wakect = 0;
1079         while (substs == 0) { sys$hiber(); wakect++;}
1080         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1081         _ckvmssts(substs);
1082         break;
1083       }
1084       _ckvmssts(sts);
1085       retlen = iosb[0] >> 16;
1086       if (!retlen) continue;  /* blank line */
1087       buf[retlen] = '\0';
1088       if (iosb[1] != subpid) {
1089         if (iosb[1]) {
1090           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1091         }
1092         continue;
1093       }
1094       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1095         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1096
1097       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1098       if (*cp1 == '(' || /* Logical name table name */
1099           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1100       if (*cp1 == '"') cp1++;
1101       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1102       key = cp1;  keylen = cp2 - cp1;
1103       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1104       while (*cp2 && *cp2 != '=') cp2++;
1105       while (*cp2 && *cp2 == '=') cp2++;
1106       while (*cp2 && *cp2 == ' ') cp2++;
1107       if (*cp2 == '"') {  /* String translation; may embed "" */
1108         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1109         cp2++;  cp1--; /* Skip "" surrounding translation */
1110       }
1111       else {  /* Numeric translation */
1112         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1113         cp1--;  /* stop on last non-space char */
1114       }
1115       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1116         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1117         continue;
1118       }
1119       PERL_HASH(hash,key,keylen);
1120
1121       if (cp1 == cp2 && *cp2 == '.') {
1122         /* A single dot usually means an unprintable character, such as a null
1123          * to indicate a zero-length value.  Get the actual value to make sure.
1124          */
1125         char lnm[LNM$C_NAMLENGTH+1];
1126         char eqv[MAX_DCL_SYMBOL+1];
1127         strncpy(lnm, key, keylen);
1128         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1129         sv = newSVpvn(eqv, strlen(eqv));
1130       }
1131       else {
1132         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1133       }
1134
1135       SvTAINTED_on(sv);
1136       hv_store(envhv,key,keylen,sv,hash);
1137       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1138     }
1139     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1140       /* get the PPFs for this process, not the subprocess */
1141       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1142       char eqv[LNM$C_NAMLENGTH+1];
1143       int trnlen, i;
1144       for (i = 0; ppfs[i]; i++) {
1145         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1146         sv = newSVpv(eqv,trnlen);
1147         SvTAINTED_on(sv);
1148         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1149       }
1150     }
1151   }
1152   primed = 1;
1153   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1154   if (buf) Safefree(buf);
1155   if (seenhv) SvREFCNT_dec(seenhv);
1156   MUTEX_UNLOCK(&primenv_mutex);
1157   return;
1158
1159 }  /* end of prime_env_iter */
1160 /*}}}*/
1161
1162
1163 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1164 /* Define or delete an element in the same "environment" as
1165  * vmstrnenv().  If an element is to be deleted, it's removed from
1166  * the first place it's found.  If it's to be set, it's set in the
1167  * place designated by the first element of the table vector.
1168  * Like setenv() returns 0 for success, non-zero on error.
1169  */
1170 int
1171 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1172 {
1173     const char *cp1;
1174     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1175     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1176     int nseg = 0, j;
1177     unsigned long int retsts, usermode = PSL$C_USER;
1178     struct itmlst_3 *ile, *ilist;
1179     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1180                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1181                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1182     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1183     $DESCRIPTOR(local,"_LOCAL");
1184
1185     if (!lnm) {
1186         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1187         return SS$_IVLOGNAM;
1188     }
1189
1190     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1191       *cp2 = _toupper(*cp1);
1192       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1193         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1194         return SS$_IVLOGNAM;
1195       }
1196     }
1197     lnmdsc.dsc$w_length = cp1 - lnm;
1198     if (!tabvec || !*tabvec) tabvec = env_tables;
1199
1200     if (!eqv) {  /* we're deleting n element */
1201       for (curtab = 0; tabvec[curtab]; curtab++) {
1202         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1203         int i;
1204           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1205             if ((cp1 = strchr(environ[i],'=')) &&
1206                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1207                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1208 #ifdef HAS_SETENV
1209               return setenv(lnm,"",1) ? vaxc$errno : 0;
1210             }
1211           }
1212           ivenv = 1; retsts = SS$_NOLOGNAM;
1213 #else
1214               if (ckWARN(WARN_INTERNAL))
1215                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1216               ivenv = 1; retsts = SS$_NOSUCHPGM;
1217               break;
1218             }
1219           }
1220 #endif
1221         }
1222         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1223                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1224           unsigned int symtype;
1225           if (tabvec[curtab]->dsc$w_length == 12 &&
1226               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1227               !str$case_blind_compare(&tmpdsc,&local))
1228             symtype = LIB$K_CLI_LOCAL_SYM;
1229           else symtype = LIB$K_CLI_GLOBAL_SYM;
1230           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1231           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1232           if (retsts == LIB$_NOSUCHSYM) continue;
1233           break;
1234         }
1235         else if (!ivlnm) {
1236           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1237           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1238           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1239           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1240           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1241         }
1242       }
1243     }
1244     else {  /* we're defining a value */
1245       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1246 #ifdef HAS_SETENV
1247         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1248 #else
1249         if (ckWARN(WARN_INTERNAL))
1250           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1251         retsts = SS$_NOSUCHPGM;
1252 #endif
1253       }
1254       else {
1255         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1256         eqvdsc.dsc$w_length  = strlen(eqv);
1257         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1258             !str$case_blind_compare(&tmpdsc,&clisym)) {
1259           unsigned int symtype;
1260           if (tabvec[0]->dsc$w_length == 12 &&
1261               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1262                !str$case_blind_compare(&tmpdsc,&local))
1263             symtype = LIB$K_CLI_LOCAL_SYM;
1264           else symtype = LIB$K_CLI_GLOBAL_SYM;
1265           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1266         }
1267         else {
1268           if (!*eqv) eqvdsc.dsc$w_length = 1;
1269           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1270
1271             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1272             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1273               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1274                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1275               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1276               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1277             }
1278
1279             Newx(ilist,nseg+1,struct itmlst_3);
1280             ile = ilist;
1281             if (!ile) {
1282               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1283               return SS$_INSFMEM;
1284             }
1285             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1286
1287             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1288               ile->itmcode = LNM$_STRING;
1289               ile->bufadr = c;
1290               if ((j+1) == nseg) {
1291                 ile->buflen = strlen(c);
1292                 /* in case we are truncating one that's too long */
1293                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1294               }
1295               else {
1296                 ile->buflen = LNM$C_NAMLENGTH;
1297               }
1298             }
1299
1300             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1301             Safefree (ilist);
1302           }
1303           else {
1304             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1305           }
1306         }
1307       }
1308     }
1309     if (!(retsts & 1)) {
1310       switch (retsts) {
1311         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1312         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1313           set_errno(EVMSERR); break;
1314         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1315         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1316           set_errno(EINVAL); break;
1317         case SS$_NOPRIV:
1318           set_errno(EACCES);
1319         default:
1320           _ckvmssts(retsts);
1321           set_errno(EVMSERR);
1322        }
1323        set_vaxc_errno(retsts);
1324        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1325     }
1326     else {
1327       /* We reset error values on success because Perl does an hv_fetch()
1328        * before each hv_store(), and if the thing we're setting didn't
1329        * previously exist, we've got a leftover error message.  (Of course,
1330        * this fails in the face of
1331        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1332        * in that the error reported in $! isn't spurious,
1333        * but it's right more often than not.)
1334        */
1335       set_errno(0); set_vaxc_errno(retsts);
1336       return 0;
1337     }
1338
1339 }  /* end of vmssetenv() */
1340 /*}}}*/
1341
1342 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1343 /* This has to be a function since there's a prototype for it in proto.h */
1344 void
1345 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1346 {
1347     if (lnm && *lnm) {
1348       int len = strlen(lnm);
1349       if  (len == 7) {
1350         char uplnm[8];
1351         int i;
1352         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1353         if (!strcmp(uplnm,"DEFAULT")) {
1354           if (eqv && *eqv) my_chdir(eqv);
1355           return;
1356         }
1357     }
1358 #ifndef RTL_USES_UTC
1359     if (len == 6 || len == 2) {
1360       char uplnm[7];
1361       int i;
1362       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1363       uplnm[len] = '\0';
1364       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1365       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1366     }
1367 #endif
1368   }
1369   (void) vmssetenv(lnm,eqv,NULL);
1370 }
1371 /*}}}*/
1372
1373 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1374 /*  vmssetuserlnm
1375  *  sets a user-mode logical in the process logical name table
1376  *  used for redirection of sys$error
1377  */
1378 void
1379 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1380 {
1381     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1382     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1383     unsigned long int iss, attr = LNM$M_CONFINE;
1384     unsigned char acmode = PSL$C_USER;
1385     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1386                                  {0, 0, 0, 0}};
1387     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1388     d_name.dsc$w_length = strlen(name);
1389
1390     lnmlst[0].buflen = strlen(eqv);
1391     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1392
1393     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1394     if (!(iss&1)) lib$signal(iss);
1395 }
1396 /*}}}*/
1397
1398
1399 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1400 /* my_crypt - VMS password hashing
1401  * my_crypt() provides an interface compatible with the Unix crypt()
1402  * C library function, and uses sys$hash_password() to perform VMS
1403  * password hashing.  The quadword hashed password value is returned
1404  * as a NUL-terminated 8 character string.  my_crypt() does not change
1405  * the case of its string arguments; in order to match the behavior
1406  * of LOGINOUT et al., alphabetic characters in both arguments must
1407  *  be upcased by the caller.
1408  *
1409  * - fix me to call ACM services when available
1410  */
1411 char *
1412 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1413 {
1414 #   ifndef UAI$C_PREFERRED_ALGORITHM
1415 #     define UAI$C_PREFERRED_ALGORITHM 127
1416 #   endif
1417     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1418     unsigned short int salt = 0;
1419     unsigned long int sts;
1420     struct const_dsc {
1421         unsigned short int dsc$w_length;
1422         unsigned char      dsc$b_type;
1423         unsigned char      dsc$b_class;
1424         const char *       dsc$a_pointer;
1425     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1426        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1427     struct itmlst_3 uailst[3] = {
1428         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1429         { sizeof salt, UAI$_SALT,    &salt, 0},
1430         { 0,           0,            NULL,  NULL}};
1431     static char hash[9];
1432
1433     usrdsc.dsc$w_length = strlen(usrname);
1434     usrdsc.dsc$a_pointer = usrname;
1435     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1436       switch (sts) {
1437         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1438           set_errno(EACCES);
1439           break;
1440         case RMS$_RNF:
1441           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1442           break;
1443         default:
1444           set_errno(EVMSERR);
1445       }
1446       set_vaxc_errno(sts);
1447       if (sts != RMS$_RNF) return NULL;
1448     }
1449
1450     txtdsc.dsc$w_length = strlen(textpasswd);
1451     txtdsc.dsc$a_pointer = textpasswd;
1452     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1453       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1454     }
1455
1456     return (char *) hash;
1457
1458 }  /* end of my_crypt() */
1459 /*}}}*/
1460
1461
1462 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1463 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1464 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1465
1466 /* fixup barenames that are directories for internal use.
1467  * There have been problems with the consistent handling of UNIX
1468  * style directory names when routines are presented with a name that
1469  * has no directory delimitors at all.  So this routine will eventually
1470  * fix the issue.
1471  */
1472 static char * fixup_bare_dirnames(const char * name)
1473 {
1474   if (decc_disable_to_vms_logname_translation) {
1475 /* fix me */
1476   }
1477   return NULL;
1478 }
1479
1480 /* mp_do_kill_file
1481  * A little hack to get around a bug in some implemenation of remove()
1482  * that do not know how to delete a directory
1483  *
1484  * Delete any file to which user has control access, regardless of whether
1485  * delete access is explicitly allowed.
1486  * Limitations: User must have write access to parent directory.
1487  *              Does not block signals or ASTs; if interrupted in midstream
1488  *              may leave file with an altered ACL.
1489  * HANDLE WITH CARE!
1490  */
1491 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1492 static int
1493 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1494 {
1495     char *vmsname, *rspec;
1496     char *remove_name;
1497     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1498     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1499     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1500     struct myacedef {
1501       unsigned char myace$b_length;
1502       unsigned char myace$b_type;
1503       unsigned short int myace$w_flags;
1504       unsigned long int myace$l_access;
1505       unsigned long int myace$l_ident;
1506     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1507                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1508       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1509      struct itmlst_3
1510        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1511                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1512        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1513        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1514        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1515        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1516
1517     /* Expand the input spec using RMS, since the CRTL remove() and
1518      * system services won't do this by themselves, so we may miss
1519      * a file "hiding" behind a logical name or search list. */
1520     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1521     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1522
1523     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1524       PerlMem_free(vmsname);
1525       return -1;
1526     }
1527
1528     if (decc_posix_compliant_pathnames) {
1529       /* In POSIX mode, we prefer to remove the UNIX name */
1530       rspec = vmsname;
1531       remove_name = (char *)name;
1532     }
1533     else {
1534       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1535       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1536       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1537         PerlMem_free(rspec);
1538         PerlMem_free(vmsname);
1539         return -1;
1540       }
1541       PerlMem_free(vmsname);
1542       remove_name = rspec;
1543     }
1544
1545 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1546     if (dirflag != 0) {
1547         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1548           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1549           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1550
1551           do_pathify_dirspec(name, remove_name, 0);
1552           if (!rmdir(remove_name)) {
1553
1554             PerlMem_free(remove_name);
1555             PerlMem_free(rspec);
1556             return 0;   /* Can we just get rid of it? */
1557           }
1558         }
1559         else {
1560           if (!rmdir(remove_name)) {
1561             PerlMem_free(rspec);
1562             return 0;   /* Can we just get rid of it? */
1563           }
1564         }
1565     }
1566     else
1567 #endif
1568       if (!remove(remove_name)) {
1569         PerlMem_free(rspec);
1570         return 0;   /* Can we just get rid of it? */
1571       }
1572
1573     /* If not, can changing protections help? */
1574     if (vaxc$errno != RMS$_PRV) {
1575       PerlMem_free(rspec);
1576       return -1;
1577     }
1578
1579     /* No, so we get our own UIC to use as a rights identifier,
1580      * and the insert an ACE at the head of the ACL which allows us
1581      * to delete the file.
1582      */
1583     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1584     fildsc.dsc$w_length = strlen(rspec);
1585     fildsc.dsc$a_pointer = rspec;
1586     cxt = 0;
1587     newace.myace$l_ident = oldace.myace$l_ident;
1588     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1589       switch (aclsts) {
1590         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1591           set_errno(ENOENT); break;
1592         case RMS$_DIR:
1593           set_errno(ENOTDIR); break;
1594         case RMS$_DEV:
1595           set_errno(ENODEV); break;
1596         case RMS$_SYN: case SS$_INVFILFOROP:
1597           set_errno(EINVAL); break;
1598         case RMS$_PRV:
1599           set_errno(EACCES); break;
1600         default:
1601           _ckvmssts(aclsts);
1602       }
1603       set_vaxc_errno(aclsts);
1604       PerlMem_free(rspec);
1605       return -1;
1606     }
1607     /* Grab any existing ACEs with this identifier in case we fail */
1608     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1609     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1610                     || fndsts == SS$_NOMOREACE ) {
1611       /* Add the new ACE . . . */
1612       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1613         goto yourroom;
1614
1615 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1616       if (dirflag != 0)
1617         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1618           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1619           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1620
1621           do_pathify_dirspec(name, remove_name, 0);
1622           rmsts = rmdir(remove_name);
1623           PerlMem_free(remove_name);
1624         }
1625         else {
1626         rmsts = rmdir(remove_name);
1627         }
1628       else
1629 #endif
1630         rmsts = remove(remove_name);
1631       if (rmsts) {
1632         /* We blew it - dir with files in it, no write priv for
1633          * parent directory, etc.  Put things back the way they were. */
1634         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1635           goto yourroom;
1636         if (fndsts & 1) {
1637           addlst[0].bufadr = &oldace;
1638           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1639             goto yourroom;
1640         }
1641       }
1642     }
1643
1644     yourroom:
1645     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1646     /* We just deleted it, so of course it's not there.  Some versions of
1647      * VMS seem to return success on the unlock operation anyhow (after all
1648      * the unlock is successful), but others don't.
1649      */
1650     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1651     if (aclsts & 1) aclsts = fndsts;
1652     if (!(aclsts & 1)) {
1653       set_errno(EVMSERR);
1654       set_vaxc_errno(aclsts);
1655       PerlMem_free(rspec);
1656       return -1;
1657     }
1658
1659     PerlMem_free(rspec);
1660     return rmsts;
1661
1662 }  /* end of kill_file() */
1663 /*}}}*/
1664
1665
1666 /*{{{int do_rmdir(char *name)*/
1667 int
1668 Perl_do_rmdir(pTHX_ const char *name)
1669 {
1670     char dirfile[NAM$C_MAXRSS+1];
1671     int retval;
1672     Stat_t st;
1673
1674     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1675     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1676     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1677     return retval;
1678
1679 }  /* end of do_rmdir */
1680 /*}}}*/
1681
1682 /* kill_file
1683  * Delete any file to which user has control access, regardless of whether
1684  * delete access is explicitly allowed.
1685  * Limitations: User must have write access to parent directory.
1686  *              Does not block signals or ASTs; if interrupted in midstream
1687  *              may leave file with an altered ACL.
1688  * HANDLE WITH CARE!
1689  */
1690 /*{{{int kill_file(char *name)*/
1691 int
1692 Perl_kill_file(pTHX_ const char *name)
1693 {
1694     char rspec[NAM$C_MAXRSS+1];
1695     char *tspec;
1696     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1697     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1698     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1699     struct myacedef {
1700       unsigned char myace$b_length;
1701       unsigned char myace$b_type;
1702       unsigned short int myace$w_flags;
1703       unsigned long int myace$l_access;
1704       unsigned long int myace$l_ident;
1705     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1706                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1707       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1708      struct itmlst_3
1709        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1710                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1711        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1712        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1713        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1714        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1715
1716     /* Expand the input spec using RMS, since the CRTL remove() and
1717      * system services won't do this by themselves, so we may miss
1718      * a file "hiding" behind a logical name or search list. */
1719     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS);
1720     if (tspec == NULL) return -1;
1721     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1722     /* If not, can changing protections help? */
1723     if (vaxc$errno != RMS$_PRV) return -1;
1724
1725     /* No, so we get our own UIC to use as a rights identifier,
1726      * and the insert an ACE at the head of the ACL which allows us
1727      * to delete the file.
1728      */
1729     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1730     fildsc.dsc$w_length = strlen(rspec);
1731     fildsc.dsc$a_pointer = rspec;
1732     cxt = 0;
1733     newace.myace$l_ident = oldace.myace$l_ident;
1734     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1735       switch (aclsts) {
1736         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1737           set_errno(ENOENT); break;
1738         case RMS$_DIR:
1739           set_errno(ENOTDIR); break;
1740         case RMS$_DEV:
1741           set_errno(ENODEV); break;
1742         case RMS$_SYN: case SS$_INVFILFOROP:
1743           set_errno(EINVAL); break;
1744         case RMS$_PRV:
1745           set_errno(EACCES); break;
1746         default:
1747           _ckvmssts(aclsts);
1748       }
1749       set_vaxc_errno(aclsts);
1750       return -1;
1751     }
1752     /* Grab any existing ACEs with this identifier in case we fail */
1753     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1754     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1755                     || fndsts == SS$_NOMOREACE ) {
1756       /* Add the new ACE . . . */
1757       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1758         goto yourroom;
1759       if ((rmsts = remove(name))) {
1760         /* We blew it - dir with files in it, no write priv for
1761          * parent directory, etc.  Put things back the way they were. */
1762         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1763           goto yourroom;
1764         if (fndsts & 1) {
1765           addlst[0].bufadr = &oldace;
1766           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1767             goto yourroom;
1768         }
1769       }
1770     }
1771
1772     yourroom:
1773     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1774     /* We just deleted it, so of course it's not there.  Some versions of
1775      * VMS seem to return success on the unlock operation anyhow (after all
1776      * the unlock is successful), but others don't.
1777      */
1778     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1779     if (aclsts & 1) aclsts = fndsts;
1780     if (!(aclsts & 1)) {
1781       set_errno(EVMSERR);
1782       set_vaxc_errno(aclsts);
1783       return -1;
1784     }
1785
1786     return rmsts;
1787
1788 }  /* end of kill_file() */
1789 /*}}}*/
1790
1791
1792 /*{{{int my_mkdir(char *,Mode_t)*/
1793 int
1794 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1795 {
1796   STRLEN dirlen = strlen(dir);
1797
1798   /* zero length string sometimes gives ACCVIO */
1799   if (dirlen == 0) return -1;
1800
1801   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1802    * null file name/type.  However, it's commonplace under Unix,
1803    * so we'll allow it for a gain in portability.
1804    */
1805   if (dir[dirlen-1] == '/') {
1806     char *newdir = savepvn(dir,dirlen-1);
1807     int ret = mkdir(newdir,mode);
1808     Safefree(newdir);
1809     return ret;
1810   }
1811   else return mkdir(dir,mode);
1812 }  /* end of my_mkdir */
1813 /*}}}*/
1814
1815 /*{{{int my_chdir(char *)*/
1816 int
1817 Perl_my_chdir(pTHX_ const char *dir)
1818 {
1819   STRLEN dirlen = strlen(dir);
1820
1821   /* zero length string sometimes gives ACCVIO */
1822   if (dirlen == 0) return -1;
1823   const char *dir1;
1824
1825   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1826    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
1827    * so that existing scripts do not need to be changed.
1828    */
1829   dir1 = dir;
1830   while ((dirlen > 0) && (*dir1 == ' ')) {
1831     dir1++;
1832     dirlen--;
1833   }
1834
1835   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1836    * that implies
1837    * null file name/type.  However, it's commonplace under Unix,
1838    * so we'll allow it for a gain in portability.
1839    *
1840    * - Preview- '/' will be valid soon on VMS
1841    */
1842   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1843     char *newdir = savepvn(dir1,dirlen-1);
1844     int ret = chdir(newdir);
1845     Safefree(newdir);
1846     return ret;
1847   }
1848   else return chdir(dir1);
1849 }  /* end of my_chdir */
1850 /*}}}*/
1851
1852
1853 /*{{{FILE *my_tmpfile()*/
1854 FILE *
1855 my_tmpfile(void)
1856 {
1857   FILE *fp;
1858   char *cp;
1859
1860   if ((fp = tmpfile())) return fp;
1861
1862   cp = PerlMem_malloc(L_tmpnam+24);
1863   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1864
1865   if (decc_filename_unix_only == 0)
1866     strcpy(cp,"Sys$Scratch:");
1867   else
1868     strcpy(cp,"/tmp/");
1869   tmpnam(cp+strlen(cp));
1870   strcat(cp,".Perltmp");
1871   fp = fopen(cp,"w+","fop=dlt");
1872   PerlMem_free(cp);
1873   return fp;
1874 }
1875 /*}}}*/
1876
1877
1878 #ifndef HOMEGROWN_POSIX_SIGNALS
1879 /*
1880  * The C RTL's sigaction fails to check for invalid signal numbers so we
1881  * help it out a bit.  The docs are correct, but the actual routine doesn't
1882  * do what the docs say it will.
1883  */
1884 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1885 int
1886 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1887                    struct sigaction* oact)
1888 {
1889   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1890         SETERRNO(EINVAL, SS$_INVARG);
1891         return -1;
1892   }
1893   return sigaction(sig, act, oact);
1894 }
1895 /*}}}*/
1896 #endif
1897
1898 #ifdef KILL_BY_SIGPRC
1899 #include <errnodef.h>
1900
1901 /* We implement our own kill() using the undocumented system service
1902    sys$sigprc for one of two reasons:
1903
1904    1.) If the kill() in an older CRTL uses sys$forcex, causing the
1905    target process to do a sys$exit, which usually can't be handled
1906    gracefully...certainly not by Perl and the %SIG{} mechanism.
1907
1908    2.) If the kill() in the CRTL can't be called from a signal
1909    handler without disappearing into the ether, i.e., the signal
1910    it purportedly sends is never trapped. Still true as of VMS 7.3.
1911
1912    sys$sigprc has the same parameters as sys$forcex, but throws an exception
1913    in the target process rather than calling sys$exit.
1914
1915    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1916    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1917    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
1918    with condition codes C$_SIG0+nsig*8, catching the exception on the
1919    target process and resignaling with appropriate arguments.
1920
1921    But we don't have that VMS 7.0+ exception handler, so if you
1922    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
1923
1924    Also note that SIGTERM is listed in the docs as being "unimplemented",
1925    yet always seems to be signaled with a VMS condition code of 4 (and
1926    correctly handled for that code).  So we hardwire it in.
1927
1928    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1929    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
1930    than signalling with an unrecognized (and unhandled by CRTL) code.
1931 */
1932
1933 #define _MY_SIG_MAX 17
1934
1935 static unsigned int
1936 Perl_sig_to_vmscondition_int(int sig)
1937 {
1938     static unsigned int sig_code[_MY_SIG_MAX+1] =
1939     {
1940         0,                  /*  0 ZERO     */
1941         SS$_HANGUP,         /*  1 SIGHUP   */
1942         SS$_CONTROLC,       /*  2 SIGINT   */
1943         SS$_CONTROLY,       /*  3 SIGQUIT  */
1944         SS$_RADRMOD,        /*  4 SIGILL   */
1945         SS$_BREAK,          /*  5 SIGTRAP  */
1946         SS$_OPCCUS,         /*  6 SIGABRT  */
1947         SS$_COMPAT,         /*  7 SIGEMT   */
1948 #ifdef __VAX
1949         SS$_FLTOVF,         /*  8 SIGFPE VAX */
1950 #else
1951         SS$_HPARITH,        /*  8 SIGFPE AXP */
1952 #endif
1953         SS$_ABORT,          /*  9 SIGKILL  */
1954         SS$_ACCVIO,         /* 10 SIGBUS   */
1955         SS$_ACCVIO,         /* 11 SIGSEGV  */
1956         SS$_BADPARAM,       /* 12 SIGSYS   */
1957         SS$_NOMBX,          /* 13 SIGPIPE  */
1958         SS$_ASTFLT,         /* 14 SIGALRM  */
1959         4,                  /* 15 SIGTERM  */
1960         0,                  /* 16 SIGUSR1  */
1961         0                   /* 17 SIGUSR2  */
1962     };
1963
1964 #if __VMS_VER >= 60200000
1965     static int initted = 0;
1966     if (!initted) {
1967         initted = 1;
1968         sig_code[16] = C$_SIGUSR1;
1969         sig_code[17] = C$_SIGUSR2;
1970     }
1971 #endif
1972
1973     if (sig < _SIG_MIN) return 0;
1974     if (sig > _MY_SIG_MAX) return 0;
1975     return sig_code[sig];
1976 }
1977
1978 unsigned int
1979 Perl_sig_to_vmscondition(int sig)
1980 {
1981 #ifdef SS$_DEBUG
1982     if (vms_debug_on_exception != 0)
1983         lib$signal(SS$_DEBUG);
1984 #endif
1985     return Perl_sig_to_vmscondition_int(sig);
1986 }
1987
1988
1989 int
1990 Perl_my_kill(int pid, int sig)
1991 {
1992     dTHX;
1993     int iss;
1994     unsigned int code;
1995     int sys$sigprc(unsigned int *pidadr,
1996                      struct dsc$descriptor_s *prcname,
1997                      unsigned int code);
1998
1999      /* sig 0 means validate the PID */
2000     /*------------------------------*/
2001     if (sig == 0) {
2002         const unsigned long int jpicode = JPI$_PID;
2003         pid_t ret_pid;
2004         int status;
2005         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2006         if ($VMS_STATUS_SUCCESS(status))
2007            return 0;
2008         switch (status) {
2009         case SS$_NOSUCHNODE:
2010         case SS$_UNREACHABLE:
2011         case SS$_NONEXPR:
2012            errno = ESRCH;
2013            break;
2014         case SS$_NOPRIV:
2015            errno = EPERM;
2016            break;
2017         default:
2018            errno = EVMSERR;
2019         }
2020         vaxc$errno=status;
2021         return -1;
2022     }
2023
2024     code = Perl_sig_to_vmscondition_int(sig);
2025
2026     if (!code) {
2027         SETERRNO(EINVAL, SS$_BADPARAM);
2028         return -1;
2029     }
2030
2031     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2032      * signals are to be sent to multiple processes.
2033      *  pid = 0 - all processes in group except ones that the system exempts
2034      *  pid = -1 - all processes except ones that the system exempts
2035      *  pid = -n - all processes in group (abs(n)) except ...
2036      * For now, just report as not supported.
2037      */
2038
2039     if (pid <= 0) {
2040         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2041         return -1;
2042     }
2043
2044     iss = sys$sigprc((unsigned int *)&pid,0,code);
2045     if (iss&1) return 0;
2046
2047     switch (iss) {
2048       case SS$_NOPRIV:
2049         set_errno(EPERM);  break;
2050       case SS$_NONEXPR:
2051       case SS$_NOSUCHNODE:
2052       case SS$_UNREACHABLE:
2053         set_errno(ESRCH);  break;
2054       case SS$_INSFMEM:
2055         set_errno(ENOMEM); break;
2056       default:
2057         _ckvmssts(iss);
2058         set_errno(EVMSERR);
2059     }
2060     set_vaxc_errno(iss);
2061
2062     return -1;
2063 }
2064 #endif
2065
2066 /* Routine to convert a VMS status code to a UNIX status code.
2067 ** More tricky than it appears because of conflicting conventions with
2068 ** existing code.
2069 **
2070 ** VMS status codes are a bit mask, with the least significant bit set for
2071 ** success.
2072 **
2073 ** Special UNIX status of EVMSERR indicates that no translation is currently
2074 ** available, and programs should check the VMS status code.
2075 **
2076 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2077 ** decoding.
2078 */
2079
2080 #ifndef C_FACILITY_NO
2081 #define C_FACILITY_NO 0x350000
2082 #endif
2083 #ifndef DCL_IVVERB
2084 #define DCL_IVVERB 0x38090
2085 #endif
2086
2087 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2088 {
2089 int facility;
2090 int fac_sp;
2091 int msg_no;
2092 int msg_status;
2093 int unix_status;
2094
2095   /* Assume the best or the worst */
2096   if (vms_status & STS$M_SUCCESS)
2097     unix_status = 0;
2098   else
2099     unix_status = EVMSERR;
2100
2101   msg_status = vms_status & ~STS$M_CONTROL;
2102
2103   facility = vms_status & STS$M_FAC_NO;
2104   fac_sp = vms_status & STS$M_FAC_SP;
2105   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2106
2107   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2108     switch(msg_no) {
2109     case SS$_NORMAL:
2110         unix_status = 0;
2111         break;
2112     case SS$_ACCVIO:
2113         unix_status = EFAULT;
2114         break;
2115     case SS$_DEVOFFLINE:
2116         unix_status = EBUSY;
2117         break;
2118     case SS$_CLEARED:
2119         unix_status = ENOTCONN;
2120         break;
2121     case SS$_IVCHAN:
2122     case SS$_IVLOGNAM:
2123     case SS$_BADPARAM:
2124     case SS$_IVLOGTAB:
2125     case SS$_NOLOGNAM:
2126     case SS$_NOLOGTAB:
2127     case SS$_INVFILFOROP:
2128     case SS$_INVARG:
2129     case SS$_NOSUCHID:
2130     case SS$_IVIDENT:
2131         unix_status = EINVAL;
2132         break;
2133     case SS$_UNSUPPORTED:
2134         unix_status = ENOTSUP;
2135         break;
2136     case SS$_FILACCERR:
2137     case SS$_NOGRPPRV:
2138     case SS$_NOSYSPRV:
2139         unix_status = EACCES;
2140         break;
2141     case SS$_DEVICEFULL:
2142         unix_status = ENOSPC;
2143         break;
2144     case SS$_NOSUCHDEV:
2145         unix_status = ENODEV;
2146         break;
2147     case SS$_NOSUCHFILE:
2148     case SS$_NOSUCHOBJECT:
2149         unix_status = ENOENT;
2150         break;
2151     case SS$_ABORT:                                 /* Fatal case */
2152     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2153     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2154         unix_status = EINTR;
2155         break;
2156     case SS$_BUFFEROVF:
2157         unix_status = E2BIG;
2158         break;
2159     case SS$_INSFMEM:
2160         unix_status = ENOMEM;
2161         break;
2162     case SS$_NOPRIV:
2163         unix_status = EPERM;
2164         break;
2165     case SS$_NOSUCHNODE:
2166     case SS$_UNREACHABLE:
2167         unix_status = ESRCH;
2168         break;
2169     case SS$_NONEXPR:
2170         unix_status = ECHILD;
2171         break;
2172     default:
2173         if ((facility == 0) && (msg_no < 8)) {
2174           /* These are not real VMS status codes so assume that they are
2175           ** already UNIX status codes
2176           */
2177           unix_status = msg_no;
2178           break;
2179         }
2180     }
2181   }
2182   else {
2183     /* Translate a POSIX exit code to a UNIX exit code */
2184     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2185         unix_status = (msg_no & 0x07F8) >> 3;
2186     }
2187     else {
2188
2189          /* Documented traditional behavior for handling VMS child exits */
2190         /*--------------------------------------------------------------*/
2191         if (child_flag != 0) {
2192
2193              /* Success / Informational return 0 */
2194             /*----------------------------------*/
2195             if (msg_no & STS$K_SUCCESS)
2196                 return 0;
2197
2198              /* Warning returns 1 */
2199             /*-------------------*/
2200             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2201                 return 1;
2202
2203              /* Everything else pass through the severity bits */
2204             /*------------------------------------------------*/
2205             return (msg_no & STS$M_SEVERITY);
2206         }
2207
2208          /* Normal VMS status to ERRNO mapping attempt */
2209         /*--------------------------------------------*/
2210         switch(msg_status) {
2211         /* case RMS$_EOF: */ /* End of File */
2212         case RMS$_FNF:  /* File Not Found */
2213         case RMS$_DNF:  /* Dir Not Found */
2214                 unix_status = ENOENT;
2215                 break;
2216         case RMS$_RNF:  /* Record Not Found */
2217                 unix_status = ESRCH;
2218                 break;
2219         case RMS$_DIR:
2220                 unix_status = ENOTDIR;
2221                 break;
2222         case RMS$_DEV:
2223                 unix_status = ENODEV;
2224                 break;
2225         case RMS$_IFI:
2226         case RMS$_FAC:
2227         case RMS$_ISI:
2228                 unix_status = EBADF;
2229                 break;
2230         case RMS$_FEX:
2231                 unix_status = EEXIST;
2232                 break;
2233         case RMS$_SYN:
2234         case RMS$_FNM:
2235         case LIB$_INVSTRDES:
2236         case LIB$_INVARG:
2237         case LIB$_NOSUCHSYM:
2238         case LIB$_INVSYMNAM:
2239         case DCL_IVVERB:
2240                 unix_status = EINVAL;
2241                 break;
2242         case CLI$_BUFOVF:
2243         case RMS$_RTB:
2244         case CLI$_TKNOVF:
2245         case CLI$_RSLOVF:
2246                 unix_status = E2BIG;
2247                 break;
2248         case RMS$_PRV:  /* No privilege */
2249         case RMS$_ACC:  /* ACP file access failed */
2250         case RMS$_WLK:  /* Device write locked */
2251                 unix_status = EACCES;
2252                 break;
2253         /* case RMS$_NMF: */  /* No more files */
2254         }
2255     }
2256   }
2257
2258   return unix_status;
2259 }
2260
2261 /* Try to guess at what VMS error status should go with a UNIX errno
2262  * value.  This is hard to do as there could be many possible VMS
2263  * error statuses that caused the errno value to be set.
2264  */
2265
2266 int Perl_unix_status_to_vms(int unix_status)
2267 {
2268 int test_unix_status;
2269
2270      /* Trivial cases first */
2271     /*---------------------*/
2272     if (unix_status == EVMSERR)
2273         return vaxc$errno;
2274
2275      /* Is vaxc$errno sane? */
2276     /*---------------------*/
2277     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2278     if (test_unix_status == unix_status)
2279         return vaxc$errno;
2280
2281      /* If way out of range, must be VMS code already */
2282     /*-----------------------------------------------*/
2283     if (unix_status > EVMSERR)
2284         return unix_status;
2285
2286      /* If out of range, punt */
2287     /*-----------------------*/
2288     if (unix_status > __ERRNO_MAX)
2289         return SS$_ABORT;
2290
2291
2292      /* Ok, now we have to do it the hard way. */
2293     /*----------------------------------------*/
2294     switch(unix_status) {
2295     case 0:     return SS$_NORMAL;
2296     case EPERM: return SS$_NOPRIV;
2297     case ENOENT: return SS$_NOSUCHOBJECT;
2298     case ESRCH: return SS$_UNREACHABLE;
2299     case EINTR: return SS$_ABORT;
2300     /* case EIO: */
2301     /* case ENXIO:  */
2302     case E2BIG: return SS$_BUFFEROVF;
2303     /* case ENOEXEC */
2304     case EBADF: return RMS$_IFI;
2305     case ECHILD: return SS$_NONEXPR;
2306     /* case EAGAIN */
2307     case ENOMEM: return SS$_INSFMEM;
2308     case EACCES: return SS$_FILACCERR;
2309     case EFAULT: return SS$_ACCVIO;
2310     /* case ENOTBLK */
2311     case EBUSY: return SS$_DEVOFFLINE;
2312     case EEXIST: return RMS$_FEX;
2313     /* case EXDEV */
2314     case ENODEV: return SS$_NOSUCHDEV;
2315     case ENOTDIR: return RMS$_DIR;
2316     /* case EISDIR */
2317     case EINVAL: return SS$_INVARG;
2318     /* case ENFILE */
2319     /* case EMFILE */
2320     /* case ENOTTY */
2321     /* case ETXTBSY */
2322     /* case EFBIG */
2323     case ENOSPC: return SS$_DEVICEFULL;
2324     case ESPIPE: return LIB$_INVARG;
2325     /* case EROFS: */
2326     /* case EMLINK: */
2327     /* case EPIPE: */
2328     /* case EDOM */
2329     case ERANGE: return LIB$_INVARG;
2330     /* case EWOULDBLOCK */
2331     /* case EINPROGRESS */
2332     /* case EALREADY */
2333     /* case ENOTSOCK */
2334     /* case EDESTADDRREQ */
2335     /* case EMSGSIZE */
2336     /* case EPROTOTYPE */
2337     /* case ENOPROTOOPT */
2338     /* case EPROTONOSUPPORT */
2339     /* case ESOCKTNOSUPPORT */
2340     /* case EOPNOTSUPP */
2341     /* case EPFNOSUPPORT */
2342     /* case EAFNOSUPPORT */
2343     /* case EADDRINUSE */
2344     /* case EADDRNOTAVAIL */
2345     /* case ENETDOWN */
2346     /* case ENETUNREACH */
2347     /* case ENETRESET */
2348     /* case ECONNABORTED */
2349     /* case ECONNRESET */
2350     /* case ENOBUFS */
2351     /* case EISCONN */
2352     case ENOTCONN: return SS$_CLEARED;
2353     /* case ESHUTDOWN */
2354     /* case ETOOMANYREFS */
2355     /* case ETIMEDOUT */
2356     /* case ECONNREFUSED */
2357     /* case ELOOP */
2358     /* case ENAMETOOLONG */
2359     /* case EHOSTDOWN */
2360     /* case EHOSTUNREACH */
2361     /* case ENOTEMPTY */
2362     /* case EPROCLIM */
2363     /* case EUSERS  */
2364     /* case EDQUOT  */
2365     /* case ENOMSG  */
2366     /* case EIDRM */
2367     /* case EALIGN */
2368     /* case ESTALE */
2369     /* case EREMOTE */
2370     /* case ENOLCK */
2371     /* case ENOSYS */
2372     /* case EFTYPE */
2373     /* case ECANCELED */
2374     /* case EFAIL */
2375     /* case EINPROG */
2376     case ENOTSUP:
2377         return SS$_UNSUPPORTED;
2378     /* case EDEADLK */
2379     /* case ENWAIT */
2380     /* case EILSEQ */
2381     /* case EBADCAT */
2382     /* case EBADMSG */
2383     /* case EABANDONED */
2384     default:
2385         return SS$_ABORT; /* punt */
2386     }
2387
2388   return SS$_ABORT; /* Should not get here */
2389 }
2390
2391
2392 /* default piping mailbox size */
2393 #define PERL_BUFSIZ        512
2394
2395
2396 static void
2397 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2398 {
2399   unsigned long int mbxbufsiz;
2400   static unsigned long int syssize = 0;
2401   unsigned long int dviitm = DVI$_DEVNAM;
2402   char csize[LNM$C_NAMLENGTH+1];
2403   int sts;
2404
2405   if (!syssize) {
2406     unsigned long syiitm = SYI$_MAXBUF;
2407     /*
2408      * Get the SYSGEN parameter MAXBUF
2409      *
2410      * If the logical 'PERL_MBX_SIZE' is defined
2411      * use the value of the logical instead of PERL_BUFSIZ, but
2412      * keep the size between 128 and MAXBUF.
2413      *
2414      */
2415     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2416   }
2417
2418   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2419       mbxbufsiz = atoi(csize);
2420   } else {
2421       mbxbufsiz = PERL_BUFSIZ;
2422   }
2423   if (mbxbufsiz < 128) mbxbufsiz = 128;
2424   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2425
2426   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2427
2428   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2429   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2430
2431 }  /* end of create_mbx() */
2432
2433
2434 /*{{{  my_popen and my_pclose*/
2435
2436 typedef struct _iosb           IOSB;
2437 typedef struct _iosb*         pIOSB;
2438 typedef struct _pipe           Pipe;
2439 typedef struct _pipe*         pPipe;
2440 typedef struct pipe_details    Info;
2441 typedef struct pipe_details*  pInfo;
2442 typedef struct _srqp            RQE;
2443 typedef struct _srqp*          pRQE;
2444 typedef struct _tochildbuf      CBuf;
2445 typedef struct _tochildbuf*    pCBuf;
2446
2447 struct _iosb {
2448     unsigned short status;
2449     unsigned short count;
2450     unsigned long  dvispec;
2451 };
2452
2453 #pragma member_alignment save
2454 #pragma nomember_alignment quadword
2455 struct _srqp {          /* VMS self-relative queue entry */
2456     unsigned long qptr[2];
2457 };
2458 #pragma member_alignment restore
2459 static RQE  RQE_ZERO = {0,0};
2460
2461 struct _tochildbuf {
2462     RQE             q;
2463     int             eof;
2464     unsigned short  size;
2465     char            *buf;
2466 };
2467
2468 struct _pipe {
2469     RQE            free;
2470     RQE            wait;
2471     int            fd_out;
2472     unsigned short chan_in;
2473     unsigned short chan_out;
2474     char          *buf;
2475     unsigned int   bufsize;
2476     IOSB           iosb;
2477     IOSB           iosb2;
2478     int           *pipe_done;
2479     int            retry;
2480     int            type;
2481     int            shut_on_empty;
2482     int            need_wake;
2483     pPipe         *home;
2484     pInfo          info;
2485     pCBuf          curr;
2486     pCBuf          curr2;
2487 #if defined(PERL_IMPLICIT_CONTEXT)
2488     void            *thx;           /* Either a thread or an interpreter */
2489                                     /* pointer, depending on how we're built */
2490 #endif
2491 };
2492
2493
2494 struct pipe_details
2495 {
2496     pInfo           next;
2497     PerlIO *fp;  /* file pointer to pipe mailbox */
2498     int useFILE; /* using stdio, not perlio */
2499     int pid;   /* PID of subprocess */
2500     int mode;  /* == 'r' if pipe open for reading */
2501     int done;  /* subprocess has completed */
2502     int waiting; /* waiting for completion/closure */
2503     int             closing;        /* my_pclose is closing this pipe */
2504     unsigned long   completion;     /* termination status of subprocess */
2505     pPipe           in;             /* pipe in to sub */
2506     pPipe           out;            /* pipe out of sub */
2507     pPipe           err;            /* pipe of sub's sys$error */
2508     int             in_done;        /* true when in pipe finished */
2509     int             out_done;
2510     int             err_done;
2511 };
2512
2513 struct exit_control_block
2514 {
2515     struct exit_control_block *flink;
2516     unsigned long int   (*exit_routine)();
2517     unsigned long int arg_count;
2518     unsigned long int *status_address;
2519     unsigned long int exit_status;
2520 };
2521
2522 typedef struct _closed_pipes    Xpipe;
2523 typedef struct _closed_pipes*  pXpipe;
2524
2525 struct _closed_pipes {
2526     int             pid;            /* PID of subprocess */
2527     unsigned long   completion;     /* termination status of subprocess */
2528 };
2529 #define NKEEPCLOSED 50
2530 static Xpipe closed_list[NKEEPCLOSED];
2531 static int   closed_index = 0;
2532 static int   closed_num = 0;
2533
2534 #define RETRY_DELAY     "0 ::0.20"
2535 #define MAX_RETRY              50
2536
2537 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2538 static unsigned long mypid;
2539 static unsigned long delaytime[2];
2540
2541 static pInfo open_pipes = NULL;
2542 static $DESCRIPTOR(nl_desc, "NL:");
2543
2544 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2545
2546
2547
2548 static unsigned long int
2549 pipe_exit_routine(pTHX)
2550 {
2551     pInfo info;
2552     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2553     int sts, did_stuff, need_eof, j;
2554
2555     /*
2556         flush any pending i/o
2557     */
2558     info = open_pipes;
2559     while (info) {
2560         if (info->fp) {
2561            if (!info->useFILE)
2562                PerlIO_flush(info->fp);   /* first, flush data */
2563            else
2564                fflush((FILE *)info->fp);
2565         }
2566         info = info->next;
2567     }
2568
2569     /*
2570      next we try sending an EOF...ignore if doesn't work, make sure we
2571      don't hang
2572     */
2573     did_stuff = 0;
2574     info = open_pipes;
2575
2576     while (info) {
2577       int need_eof;
2578       _ckvmssts_noperl(sys$setast(0));
2579       if (info->in && !info->in->shut_on_empty) {
2580         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2581                           0, 0, 0, 0, 0, 0));
2582         info->waiting = 1;
2583         did_stuff = 1;
2584       }
2585       _ckvmssts_noperl(sys$setast(1));
2586       info = info->next;
2587     }
2588
2589     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2590
2591     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2592         int nwait = 0;
2593
2594         info = open_pipes;
2595         while (info) {
2596           _ckvmssts_noperl(sys$setast(0));
2597           if (info->waiting && info->done)
2598                 info->waiting = 0;
2599           nwait += info->waiting;
2600           _ckvmssts_noperl(sys$setast(1));
2601           info = info->next;
2602         }
2603         if (!nwait) break;
2604         sleep(1);
2605     }
2606
2607     did_stuff = 0;
2608     info = open_pipes;
2609     while (info) {
2610       _ckvmssts_noperl(sys$setast(0));
2611       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2612         sts = sys$forcex(&info->pid,0,&abort);
2613         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2614         did_stuff = 1;
2615       }
2616       _ckvmssts_noperl(sys$setast(1));
2617       info = info->next;
2618     }
2619
2620     /* again, wait for effect */
2621
2622     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2623         int nwait = 0;
2624
2625         info = open_pipes;
2626         while (info) {
2627           _ckvmssts_noperl(sys$setast(0));
2628           if (info->waiting && info->done)
2629                 info->waiting = 0;
2630           nwait += info->waiting;
2631           _ckvmssts_noperl(sys$setast(1));
2632           info = info->next;
2633         }
2634         if (!nwait) break;
2635         sleep(1);
2636     }
2637
2638     info = open_pipes;
2639     while (info) {
2640       _ckvmssts_noperl(sys$setast(0));
2641       if (!info->done) {  /* We tried to be nice . . . */
2642         sts = sys$delprc(&info->pid,0);
2643         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2644       }
2645       _ckvmssts_noperl(sys$setast(1));
2646       info = info->next;
2647     }
2648
2649     while(open_pipes) {
2650       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2651       else if (!(sts & 1)) retsts = sts;
2652     }
2653     return retsts;
2654 }
2655
2656 static struct exit_control_block pipe_exitblock =
2657        {(struct exit_control_block *) 0,
2658         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2659
2660 static void pipe_mbxtofd_ast(pPipe p);
2661 static void pipe_tochild1_ast(pPipe p);
2662 static void pipe_tochild2_ast(pPipe p);
2663
2664 static void
2665 popen_completion_ast(pInfo info)
2666 {
2667   pInfo i = open_pipes;
2668   int iss;
2669   int sts;
2670   pXpipe x;
2671
2672   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2673   closed_list[closed_index].pid = info->pid;
2674   closed_list[closed_index].completion = info->completion;
2675   closed_index++;
2676   if (closed_index == NKEEPCLOSED)
2677     closed_index = 0;
2678   closed_num++;
2679
2680   while (i) {
2681     if (i == info) break;
2682     i = i->next;
2683   }
2684   if (!i) return;       /* unlinked, probably freed too */
2685
2686   info->done = TRUE;
2687
2688 /*
2689     Writing to subprocess ...
2690             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2691
2692             chan_out may be waiting for "done" flag, or hung waiting
2693             for i/o completion to child...cancel the i/o.  This will
2694             put it into "snarf mode" (done but no EOF yet) that discards
2695             input.
2696
2697     Output from subprocess (stdout, stderr) needs to be flushed and
2698     shut down.   We try sending an EOF, but if the mbx is full the pipe
2699     routine should still catch the "shut_on_empty" flag, telling it to
2700     use immediate-style reads so that "mbx empty" -> EOF.
2701
2702
2703 */
2704   if (info->in && !info->in_done) {               /* only for mode=w */
2705         if (info->in->shut_on_empty && info->in->need_wake) {
2706             info->in->need_wake = FALSE;
2707             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2708         } else {
2709             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2710         }
2711   }
2712
2713   if (info->out && !info->out_done) {             /* were we also piping output? */
2714       info->out->shut_on_empty = TRUE;
2715       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2716       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2717       _ckvmssts_noperl(iss);
2718   }
2719
2720   if (info->err && !info->err_done) {        /* we were piping stderr */
2721         info->err->shut_on_empty = TRUE;
2722         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2723         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2724         _ckvmssts_noperl(iss);
2725   }
2726   _ckvmssts_noperl(sys$setef(pipe_ef));
2727
2728 }
2729
2730 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2731 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2732
2733 /*
2734     we actually differ from vmstrnenv since we use this to
2735     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2736     are pointing to the same thing
2737 */
2738
2739 static unsigned short
2740 popen_translate(pTHX_ char *logical, char *result)
2741 {
2742     int iss;
2743     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2744     $DESCRIPTOR(d_log,"");
2745     struct _il3 {
2746         unsigned short length;
2747         unsigned short code;
2748         char *         buffer_addr;
2749         unsigned short *retlenaddr;
2750     } itmlst[2];
2751     unsigned short l, ifi;
2752
2753     d_log.dsc$a_pointer = logical;
2754     d_log.dsc$w_length  = strlen(logical);
2755
2756     itmlst[0].code = LNM$_STRING;
2757     itmlst[0].length = 255;
2758     itmlst[0].buffer_addr = result;
2759     itmlst[0].retlenaddr = &l;
2760
2761     itmlst[1].code = 0;
2762     itmlst[1].length = 0;
2763     itmlst[1].buffer_addr = 0;
2764     itmlst[1].retlenaddr = 0;
2765
2766     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2767     if (iss == SS$_NOLOGNAM) {
2768         iss = SS$_NORMAL;
2769         l = 0;
2770     }
2771     if (!(iss&1)) lib$signal(iss);
2772     result[l] = '\0';
2773 /*
2774     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
2775     strip it off and return the ifi, if any
2776 */
2777     ifi  = 0;
2778     if (result[0] == 0x1b && result[1] == 0x00) {
2779         memmove(&ifi,result+2,2);
2780         strcpy(result,result+4);
2781     }
2782     return ifi;     /* this is the RMS internal file id */
2783 }
2784
2785 static void pipe_infromchild_ast(pPipe p);
2786
2787 /*
2788     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2789     inside an AST routine without worrying about reentrancy and which Perl
2790     memory allocator is being used.
2791
2792     We read data and queue up the buffers, then spit them out one at a
2793     time to the output mailbox when the output mailbox is ready for one.
2794
2795 */
2796 #define INITIAL_TOCHILDQUEUE  2
2797
2798 static pPipe
2799 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2800 {
2801     pPipe p;
2802     pCBuf b;
2803     char mbx1[64], mbx2[64];
2804     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2805                                       DSC$K_CLASS_S, mbx1},
2806                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2807                                       DSC$K_CLASS_S, mbx2};
2808     unsigned int dviitm = DVI$_DEVBUFSIZ;
2809     int j, n;
2810
2811     n = sizeof(Pipe);
2812     _ckvmssts(lib$get_vm(&n, &p));
2813
2814     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2815     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2816     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2817
2818     p->buf           = 0;
2819     p->shut_on_empty = FALSE;
2820     p->need_wake     = FALSE;
2821     p->type          = 0;
2822     p->retry         = 0;
2823     p->iosb.status   = SS$_NORMAL;
2824     p->iosb2.status  = SS$_NORMAL;
2825     p->free          = RQE_ZERO;
2826     p->wait          = RQE_ZERO;
2827     p->curr          = 0;
2828     p->curr2         = 0;
2829     p->info          = 0;
2830 #ifdef PERL_IMPLICIT_CONTEXT
2831     p->thx           = aTHX;
2832 #endif
2833
2834     n = sizeof(CBuf) + p->bufsize;
2835
2836     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2837         _ckvmssts(lib$get_vm(&n, &b));
2838         b->buf = (char *) b + sizeof(CBuf);
2839         _ckvmssts(lib$insqhi(b, &p->free));
2840     }
2841
2842     pipe_tochild2_ast(p);
2843     pipe_tochild1_ast(p);
2844     strcpy(wmbx, mbx1);
2845     strcpy(rmbx, mbx2);
2846     return p;
2847 }
2848
2849 /*  reads the MBX Perl is writing, and queues */
2850
2851 static void
2852 pipe_tochild1_ast(pPipe p)
2853 {
2854     pCBuf b = p->curr;
2855     int iss = p->iosb.status;
2856     int eof = (iss == SS$_ENDOFFILE);
2857     int sts;
2858 #ifdef PERL_IMPLICIT_CONTEXT
2859     pTHX = p->thx;
2860 #endif
2861
2862     if (p->retry) {
2863         if (eof) {
2864             p->shut_on_empty = TRUE;
2865             b->eof     = TRUE;
2866             _ckvmssts(sys$dassgn(p->chan_in));
2867         } else  {
2868             _ckvmssts(iss);
2869         }
2870
2871         b->eof  = eof;
2872         b->size = p->iosb.count;
2873         _ckvmssts(sts = lib$insqhi(b, &p->wait));
2874         if (p->need_wake) {
2875             p->need_wake = FALSE;
2876             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2877         }
2878     } else {
2879         p->retry = 1;   /* initial call */
2880     }
2881
2882     if (eof) {                  /* flush the free queue, return when done */
2883         int n = sizeof(CBuf) + p->bufsize;
2884         while (1) {
2885             iss = lib$remqti(&p->free, &b);
2886             if (iss == LIB$_QUEWASEMP) return;
2887             _ckvmssts(iss);
2888             _ckvmssts(lib$free_vm(&n, &b));
2889         }
2890     }
2891
2892     iss = lib$remqti(&p->free, &b);
2893     if (iss == LIB$_QUEWASEMP) {
2894         int n = sizeof(CBuf) + p->bufsize;
2895         _ckvmssts(lib$get_vm(&n, &b));
2896         b->buf = (char *) b + sizeof(CBuf);
2897     } else {
2898        _ckvmssts(iss);
2899     }
2900
2901     p->curr = b;
2902     iss = sys$qio(0,p->chan_in,
2903              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2904              &p->iosb,
2905              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2906     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2907     _ckvmssts(iss);
2908 }
2909
2910
2911 /* writes queued buffers to output, waits for each to complete before
2912    doing the next */
2913
2914 static void
2915 pipe_tochild2_ast(pPipe p)
2916 {
2917     pCBuf b = p->curr2;
2918     int iss = p->iosb2.status;
2919     int n = sizeof(CBuf) + p->bufsize;
2920     int done = (p->info && p->info->done) ||
2921               iss == SS$_CANCEL || iss == SS$_ABORT;
2922 #if defined(PERL_IMPLICIT_CONTEXT)
2923     pTHX = p->thx;
2924 #endif
2925
2926     do {
2927         if (p->type) {         /* type=1 has old buffer, dispose */
2928             if (p->shut_on_empty) {
2929                 _ckvmssts(lib$free_vm(&n, &b));
2930             } else {
2931                 _ckvmssts(lib$insqhi(b, &p->free));
2932             }
2933             p->type = 0;
2934         }
2935
2936         iss = lib$remqti(&p->wait, &b);
2937         if (iss == LIB$_QUEWASEMP) {
2938             if (p->shut_on_empty) {
2939                 if (done) {
2940                     _ckvmssts(sys$dassgn(p->chan_out));
2941                     *p->pipe_done = TRUE;
2942                     _ckvmssts(sys$setef(pipe_ef));
2943                 } else {
2944                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2945                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2946                 }
2947                 return;
2948             }
2949             p->need_wake = TRUE;
2950             return;
2951         }
2952         _ckvmssts(iss);
2953         p->type = 1;
2954     } while (done);
2955
2956
2957     p->curr2 = b;
2958     if (b->eof) {
2959         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2960             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2961     } else {
2962         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2963             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2964     }
2965
2966     return;
2967
2968 }
2969
2970
2971 static pPipe
2972 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2973 {
2974     pPipe p;
2975     char mbx1[64], mbx2[64];
2976     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2977                                       DSC$K_CLASS_S, mbx1},
2978                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2979                                       DSC$K_CLASS_S, mbx2};
2980     unsigned int dviitm = DVI$_DEVBUFSIZ;
2981
2982     int n = sizeof(Pipe);
2983     _ckvmssts(lib$get_vm(&n, &p));
2984     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2985     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2986
2987     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2988     n = p->bufsize * sizeof(char);
2989     _ckvmssts(lib$get_vm(&n, &p->buf));
2990     p->shut_on_empty = FALSE;
2991     p->info   = 0;
2992     p->type   = 0;
2993     p->iosb.status = SS$_NORMAL;
2994 #if defined(PERL_IMPLICIT_CONTEXT)
2995     p->thx = aTHX;
2996 #endif
2997     pipe_infromchild_ast(p);
2998
2999     strcpy(wmbx, mbx1);
3000     strcpy(rmbx, mbx2);
3001     return p;
3002 }
3003
3004 static void
3005 pipe_infromchild_ast(pPipe p)
3006 {
3007     int iss = p->iosb.status;
3008     int eof = (iss == SS$_ENDOFFILE);
3009     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3010     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3011 #if defined(PERL_IMPLICIT_CONTEXT)
3012     pTHX = p->thx;
3013 #endif
3014
3015     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3016         _ckvmssts(sys$dassgn(p->chan_out));
3017         p->chan_out = 0;
3018     }
3019
3020     /* read completed:
3021             input shutdown if EOF from self (done or shut_on_empty)
3022             output shutdown if closing flag set (my_pclose)
3023             send data/eof from child or eof from self
3024             otherwise, re-read (snarf of data from child)
3025     */
3026
3027     if (p->type == 1) {
3028         p->type = 0;
3029         if (myeof && p->chan_in) {                  /* input shutdown */
3030             _ckvmssts(sys$dassgn(p->chan_in));
3031             p->chan_in = 0;
3032         }
3033
3034         if (p->chan_out) {
3035             if (myeof || kideof) {      /* pass EOF to parent */
3036                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3037                               pipe_infromchild_ast, p,
3038                               0, 0, 0, 0, 0, 0));
3039                 return;
3040             } else if (eof) {       /* eat EOF --- fall through to read*/
3041
3042             } else {                /* transmit data */
3043                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3044                               pipe_infromchild_ast,p,
3045                               p->buf, p->iosb.count, 0, 0, 0, 0));
3046                 return;
3047             }
3048         }
3049     }
3050
3051     /*  everything shut? flag as done */
3052
3053     if (!p->chan_in && !p->chan_out) {
3054         *p->pipe_done = TRUE;
3055         _ckvmssts(sys$setef(pipe_ef));
3056         return;
3057     }
3058
3059     /* write completed (or read, if snarfing from child)
3060             if still have input active,
3061                queue read...immediate mode if shut_on_empty so we get EOF if empty
3062             otherwise,
3063                check if Perl reading, generate EOFs as needed
3064     */
3065
3066     if (p->type == 0) {
3067         p->type = 1;
3068         if (p->chan_in) {
3069             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3070                           pipe_infromchild_ast,p,
3071                           p->buf, p->bufsize, 0, 0, 0, 0);
3072             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3073             _ckvmssts(iss);
3074         } else {           /* send EOFs for extra reads */
3075             p->iosb.status = SS$_ENDOFFILE;
3076             p->iosb.dvispec = 0;
3077             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3078                       0, 0, 0,
3079                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3080         }
3081     }
3082 }
3083
3084 static pPipe
3085 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3086 {
3087     pPipe p;
3088     char mbx[64];
3089     unsigned long dviitm = DVI$_DEVBUFSIZ;
3090     struct stat s;
3091     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3092                                       DSC$K_CLASS_S, mbx};
3093     int n = sizeof(Pipe);
3094
3095     /* things like terminals and mbx's don't need this filter */
3096     if (fd && fstat(fd,&s) == 0) {
3097         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3098         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
3099                                          DSC$K_CLASS_S, s.st_dev};
3100
3101         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
3102         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
3103             strcpy(out, s.st_dev);
3104             return 0;
3105         }
3106     }
3107
3108     _ckvmssts(lib$get_vm(&n, &p));
3109     p->fd_out = dup(fd);
3110     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3111     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3112     n = (p->bufsize+1) * sizeof(char);
3113     _ckvmssts(lib$get_vm(&n, &p->buf));
3114     p->shut_on_empty = FALSE;
3115     p->retry = 0;
3116     p->info  = 0;
3117     strcpy(out, mbx);
3118
3119     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3120                   pipe_mbxtofd_ast, p,
3121                   p->buf, p->bufsize, 0, 0, 0, 0));
3122
3123     return p;
3124 }
3125
3126 static void
3127 pipe_mbxtofd_ast(pPipe p)
3128 {
3129     int iss = p->iosb.status;
3130     int done = p->info->done;
3131     int iss2;
3132     int eof = (iss == SS$_ENDOFFILE);
3133     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3134     int err = !(iss&1) && !eof;
3135 #if defined(PERL_IMPLICIT_CONTEXT)
3136     pTHX = p->thx;
3137 #endif
3138
3139     if (done && myeof) {               /* end piping */
3140         close(p->fd_out);
3141         sys$dassgn(p->chan_in);
3142         *p->pipe_done = TRUE;
3143         _ckvmssts(sys$setef(pipe_ef));
3144         return;
3145     }
3146
3147     if (!err && !eof) {             /* good data to send to file */
3148         p->buf[p->iosb.count] = '\n';
3149         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3150         if (iss2 < 0) {
3151             p->retry++;
3152             if (p->retry < MAX_RETRY) {
3153                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3154                 return;
3155             }
3156         }
3157         p->retry = 0;
3158     } else if (err) {
3159         _ckvmssts(iss);
3160     }
3161
3162
3163     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3164           pipe_mbxtofd_ast, p,
3165           p->buf, p->bufsize, 0, 0, 0, 0);
3166     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3167     _ckvmssts(iss);
3168 }
3169
3170
3171 typedef struct _pipeloc     PLOC;
3172 typedef struct _pipeloc*   pPLOC;
3173
3174 struct _pipeloc {
3175     pPLOC   next;
3176     char    dir[NAM$C_MAXRSS+1];
3177 };
3178 static pPLOC  head_PLOC = 0;
3179
3180 void
3181 free_pipelocs(pTHX_ void *head)
3182 {
3183     pPLOC p, pnext;
3184     pPLOC *pHead = (pPLOC *)head;
3185
3186     p = *pHead;
3187     while (p) {
3188         pnext = p->next;
3189         PerlMem_free(p);
3190         p = pnext;
3191     }
3192     *pHead = 0;
3193 }
3194
3195 static void
3196 store_pipelocs(pTHX)
3197 {
3198     int    i;
3199     pPLOC  p;
3200     AV    *av = 0;
3201     SV    *dirsv;
3202     GV    *gv;
3203     char  *dir, *x;
3204     char  *unixdir;
3205     char  temp[NAM$C_MAXRSS+1];
3206     STRLEN n_a;
3207
3208     if (head_PLOC)
3209         free_pipelocs(aTHX_ &head_PLOC);
3210
3211 /*  the . directory from @INC comes last */
3212
3213     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3214     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3215     p->next = head_PLOC;
3216     head_PLOC = p;
3217     strcpy(p->dir,"./");
3218
3219 /*  get the directory from $^X */
3220
3221     unixdir = PerlMem_malloc(VMS_MAXRSS);
3222     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3223
3224 #ifdef PERL_IMPLICIT_CONTEXT
3225     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3226 #else
3227     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3228 #endif
3229         strcpy(temp, PL_origargv[0]);
3230         x = strrchr(temp,']');
3231         if (x == NULL) {
3232         x = strrchr(temp,'>');
3233           if (x == NULL) {
3234             /* It could be a UNIX path */
3235             x = strrchr(temp,'/');
3236           }
3237         }
3238         if (x)
3239           x[1] = '\0';
3240         else {
3241           /* Got a bare name, so use default directory */
3242           temp[0] = '.';
3243           temp[1] = '\0';
3244         }
3245
3246         if ((tounixpath(temp, unixdir)) != Nullch) {
3247             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3248             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3249             p->next = head_PLOC;
3250             head_PLOC = p;
3251             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3252             p->dir[NAM$C_MAXRSS] = '\0';
3253         }
3254     }
3255
3256 /*  reverse order of @INC entries, skip "." since entered above */
3257
3258 #ifdef PERL_IMPLICIT_CONTEXT
3259     if (aTHX)
3260 #endif
3261     if (PL_incgv) av = GvAVn(PL_incgv);
3262
3263     for (i = 0; av && i <= AvFILL(av); i++) {
3264         dirsv = *av_fetch(av,i,TRUE);
3265
3266         if (SvROK(dirsv)) continue;
3267         dir = SvPVx(dirsv,n_a);
3268         if (strcmp(dir,".") == 0) continue;
3269         if ((tounixpath(dir, unixdir)) == Nullch)
3270             continue;
3271
3272         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3273         p->next = head_PLOC;
3274         head_PLOC = p;
3275         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3276         p->dir[NAM$C_MAXRSS] = '\0';
3277     }
3278
3279 /* most likely spot (ARCHLIB) put first in the list */
3280
3281 #ifdef ARCHLIB_EXP
3282     if ((tounixpath(ARCHLIB_EXP, unixdir)) != Nullch) {
3283         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3284         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3285         p->next = head_PLOC;
3286         head_PLOC = p;
3287         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3288         p->dir[NAM$C_MAXRSS] = '\0';
3289     }
3290 #endif
3291     PerlMem_free(unixdir);
3292 }
3293
3294
3295 static char *
3296 find_vmspipe(pTHX)
3297 {
3298     static int   vmspipe_file_status = 0;
3299     static char  vmspipe_file[NAM$C_MAXRSS+1];
3300
3301     /* already found? Check and use ... need read+execute permission */
3302
3303     if (vmspipe_file_status == 1) {
3304         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3305          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3306             return vmspipe_file;
3307         }
3308         vmspipe_file_status = 0;
3309     }
3310
3311     /* scan through stored @INC, $^X */
3312
3313     if (vmspipe_file_status == 0) {
3314         char file[NAM$C_MAXRSS+1];
3315         pPLOC  p = head_PLOC;
3316
3317         while (p) {
3318             char * exp_res;
3319             int dirlen;
3320             strcpy(file, p->dir);
3321             dirlen = strlen(file);
3322             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3323             file[NAM$C_MAXRSS] = '\0';
3324             p = p->next;
3325
3326             exp_res = do_rmsexpand
3327                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS);
3328             if (!exp_res) continue;
3329
3330             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3331              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3332                 vmspipe_file_status = 1;
3333                 return vmspipe_file;
3334             }
3335         }
3336         vmspipe_file_status = -1;   /* failed, use tempfiles */
3337     }
3338
3339     return 0;
3340 }
3341
3342 static FILE *
3343 vmspipe_tempfile(pTHX)
3344 {
3345     char file[NAM$C_MAXRSS+1];
3346     FILE *fp;
3347     static int index = 0;
3348     Stat_t s0, s1;
3349     int cmp_result;
3350
3351     /* create a tempfile */
3352
3353     /* we can't go from   W, shr=get to  R, shr=get without
3354        an intermediate vulnerable state, so don't bother trying...
3355
3356        and lib$spawn doesn't shr=put, so have to close the write
3357
3358        So... match up the creation date/time and the FID to
3359        make sure we're dealing with the same file
3360
3361     */
3362
3363     index++;
3364     if (!decc_filename_unix_only) {
3365       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3366       fp = fopen(file,"w");
3367       if (!fp) {
3368         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3369         fp = fopen(file,"w");
3370         if (!fp) {
3371             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3372             fp = fopen(file,"w");
3373         }
3374       }
3375      }
3376      else {
3377       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3378       fp = fopen(file,"w");
3379       if (!fp) {
3380         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3381         fp = fopen(file,"w");
3382         if (!fp) {
3383           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3384           fp = fopen(file,"w");
3385         }
3386       }
3387     }
3388     if (!fp) return 0;  /* we're hosed */
3389
3390     fprintf(fp,"$! 'f$verify(0)'\n");
3391     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3392     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3393     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3394     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3395     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3396     fprintf(fp,"$ perl_del    = \"delete\"\n");
3397     fprintf(fp,"$ pif         = \"if\"\n");
3398     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3399     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3400     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3401     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3402     fprintf(fp,"$!  --- build command line to get max possible length\n");
3403     fprintf(fp,"$c=perl_popen_cmd0\n");
3404     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3405     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3406     fprintf(fp,"$x=perl_popen_cmd3\n");
3407     fprintf(fp,"$c=c+x\n");
3408     fprintf(fp,"$ perl_on\n");
3409     fprintf(fp,"$ 'c'\n");
3410     fprintf(fp,"$ perl_status = $STATUS\n");
3411     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3412     fprintf(fp,"$ perl_exit 'perl_status'\n");
3413     fsync(fileno(fp));
3414
3415     fgetname(fp, file, 1);
3416     fstat(fileno(fp), (struct stat *)&s0);
3417     fclose(fp);
3418
3419     if (decc_filename_unix_only)
3420         do_tounixspec(file, file, 0);
3421     fp = fopen(file,"r","shr=get");
3422     if (!fp) return 0;
3423     fstat(fileno(fp), (struct stat *)&s1);
3424
3425     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3426     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3427         fclose(fp);
3428         return 0;
3429     }
3430
3431     return fp;
3432 }
3433
3434
3435
3436 static PerlIO *
3437 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3438 {
3439     static int handler_set_up = FALSE;
3440     unsigned long int sts, flags = CLI$M_NOWAIT;
3441     /* The use of a GLOBAL table (as was done previously) rendered
3442      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3443      * environment.  Hence we've switched to LOCAL symbol table.
3444      */
3445     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3446     int j, wait = 0, n;
3447     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3448     char in[512], out[512], err[512], mbx[512];
3449     FILE *tpipe = 0;
3450     char tfilebuf[NAM$C_MAXRSS+1];
3451     pInfo info = NULL;
3452     char cmd_sym_name[20];
3453     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3454                                       DSC$K_CLASS_S, symbol};
3455     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3456                                       DSC$K_CLASS_S, 0};
3457     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3458                                       DSC$K_CLASS_S, cmd_sym_name};
3459     struct dsc$descriptor_s *vmscmd;
3460     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3461     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3462     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3463
3464     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3465
3466     /* once-per-program initialization...
3467        note that the SETAST calls and the dual test of pipe_ef
3468        makes sure that only the FIRST thread through here does
3469        the initialization...all other threads wait until it's
3470        done.
3471
3472        Yeah, uglier than a pthread call, it's got all the stuff inline
3473        rather than in a separate routine.
3474     */
3475
3476     if (!pipe_ef) {
3477         _ckvmssts(sys$setast(0));
3478         if (!pipe_ef) {
3479             unsigned long int pidcode = JPI$_PID;
3480             $DESCRIPTOR(d_delay, RETRY_DELAY);
3481             _ckvmssts(lib$get_ef(&pipe_ef));
3482             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3483             _ckvmssts(sys$bintim(&d_delay, delaytime));
3484         }
3485         if (!handler_set_up) {
3486           _ckvmssts(sys$dclexh(&pipe_exitblock));
3487           handler_set_up = TRUE;
3488         }
3489         _ckvmssts(sys$setast(1));
3490     }
3491
3492     /* see if we can find a VMSPIPE.COM */
3493
3494     tfilebuf[0] = '@';
3495     vmspipe = find_vmspipe(aTHX);
3496     if (vmspipe) {
3497         strcpy(tfilebuf+1,vmspipe);
3498     } else {        /* uh, oh...we're in tempfile hell */
3499         tpipe = vmspipe_tempfile(aTHX);
3500         if (!tpipe) {       /* a fish popular in Boston */
3501             if (ckWARN(WARN_PIPE)) {
3502                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3503             }
3504         return Nullfp;
3505         }
3506         fgetname(tpipe,tfilebuf+1,1);
3507     }
3508     vmspipedsc.dsc$a_pointer = tfilebuf;
3509     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3510
3511     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3512     if (!(sts & 1)) {
3513       switch (sts) {
3514         case RMS$_FNF:  case RMS$_DNF:
3515           set_errno(ENOENT); break;
3516         case RMS$_DIR:
3517           set_errno(ENOTDIR); break;
3518         case RMS$_DEV:
3519           set_errno(ENODEV); break;
3520         case RMS$_PRV:
3521           set_errno(EACCES); break;
3522         case RMS$_SYN:
3523           set_errno(EINVAL); break;
3524         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3525           set_errno(E2BIG); break;
3526         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3527           _ckvmssts(sts); /* fall through */
3528         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3529           set_errno(EVMSERR);
3530       }
3531       set_vaxc_errno(sts);
3532       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3533         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3534       }
3535       *psts = sts;
3536       return Nullfp;
3537     }
3538     n = sizeof(Info);
3539     _ckvmssts(lib$get_vm(&n, &info));
3540
3541     strcpy(mode,in_mode);
3542     info->mode = *mode;
3543     info->done = FALSE;
3544     info->completion = 0;
3545     info->closing    = FALSE;
3546     info->in         = 0;
3547     info->out        = 0;
3548     info->err        = 0;
3549     info->fp         = Nullfp;
3550     info->useFILE    = 0;
3551     info->waiting    = 0;
3552     info->in_done    = TRUE;
3553     info->out_done   = TRUE;
3554     info->err_done   = TRUE;
3555     in[0] = out[0] = err[0] = '\0';
3556
3557     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3558         info->useFILE = 1;
3559         strcpy(p,p+1);
3560     }
3561     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3562         wait = 1;
3563         strcpy(p,p+1);
3564     }
3565
3566     if (*mode == 'r') {             /* piping from subroutine */
3567
3568         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3569         if (info->out) {
3570             info->out->pipe_done = &info->out_done;
3571             info->out_done = FALSE;
3572             info->out->info = info;
3573         }
3574         if (!info->useFILE) {
3575         info->fp  = PerlIO_open(mbx, mode);
3576         } else {
3577             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3578             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3579         }
3580
3581         if (!info->fp && info->out) {
3582             sys$cancel(info->out->chan_out);
3583
3584             while (!info->out_done) {
3585                 int done;
3586                 _ckvmssts(sys$setast(0));
3587                 done = info->out_done;
3588                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3589                 _ckvmssts(sys$setast(1));
3590                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3591             }
3592
3593             if (info->out->buf) {
3594                 n = info->out->bufsize * sizeof(char);
3595                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3596             }
3597             n = sizeof(Pipe);
3598             _ckvmssts(lib$free_vm(&n, &info->out));
3599             n = sizeof(Info);
3600             _ckvmssts(lib$free_vm(&n, &info));
3601             *psts = RMS$_FNF;
3602             return Nullfp;
3603         }
3604
3605         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3606         if (info->err) {
3607             info->err->pipe_done = &info->err_done;
3608             info->err_done = FALSE;
3609             info->err->info = info;
3610         }
3611
3612     } else if (*mode == 'w') {      /* piping to subroutine */
3613
3614         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3615         if (info->out) {
3616             info->out->pipe_done = &info->out_done;
3617             info->out_done = FALSE;
3618             info->out->info = info;
3619         }
3620
3621         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3622         if (info->err) {
3623             info->err->pipe_done = &info->err_done;
3624             info->err_done = FALSE;
3625             info->err->info = info;
3626         }
3627
3628         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3629         if (!info->useFILE) {
3630             info->fp  = PerlIO_open(mbx, mode);
3631         } else {
3632             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3633             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3634         }
3635
3636         if (info->in) {
3637             info->in->pipe_done = &info->in_done;
3638             info->in_done = FALSE;
3639             info->in->info = info;
3640         }
3641
3642         /* error cleanup */
3643         if (!info->fp && info->in) {
3644             info->done = TRUE;
3645             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3646                               0, 0, 0, 0, 0, 0, 0, 0));
3647
3648             while (!info->in_done) {
3649                 int done;
3650                 _ckvmssts(sys$setast(0));
3651                 done = info->in_done;
3652                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3653                 _ckvmssts(sys$setast(1));
3654                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3655             }
3656
3657             if (info->in->buf) {
3658                 n = info->in->bufsize * sizeof(char);
3659                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3660             }
3661             n = sizeof(Pipe);
3662             _ckvmssts(lib$free_vm(&n, &info->in));
3663             n = sizeof(Info);
3664             _ckvmssts(lib$free_vm(&n, &info));
3665             *psts = RMS$_FNF;
3666             return Nullfp;
3667         }
3668
3669
3670     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3671         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3672         if (info->out) {
3673             info->out->pipe_done = &info->out_done;
3674             info->out_done = FALSE;
3675             info->out->info = info;
3676         }
3677
3678         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3679         if (info->err) {
3680             info->err->pipe_done = &info->err_done;
3681             info->err_done = FALSE;
3682             info->err->info = info;
3683         }
3684     }
3685
3686     symbol[MAX_DCL_SYMBOL] = '\0';
3687
3688     strncpy(symbol, in, MAX_DCL_SYMBOL);
3689     d_symbol.dsc$w_length = strlen(symbol);
3690     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3691
3692     strncpy(symbol, err, MAX_DCL_SYMBOL);
3693     d_symbol.dsc$w_length = strlen(symbol);
3694     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3695
3696     strncpy(symbol, out, MAX_DCL_SYMBOL);
3697     d_symbol.dsc$w_length = strlen(symbol);
3698     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3699
3700     p = vmscmd->dsc$a_pointer;
3701     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
3702     if (*p == '$') p++;                         /* remove leading $ */
3703     while (*p == ' ' || *p == '\t') p++;
3704
3705     for (j = 0; j < 4; j++) {
3706         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3707         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3708
3709     strncpy(symbol, p, MAX_DCL_SYMBOL);
3710     d_symbol.dsc$w_length = strlen(symbol);
3711     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3712
3713         if (strlen(p) > MAX_DCL_SYMBOL) {
3714             p += MAX_DCL_SYMBOL;
3715         } else {
3716             p += strlen(p);
3717         }
3718     }
3719     _ckvmssts(sys$setast(0));
3720     info->next=open_pipes;  /* prepend to list */
3721     open_pipes=info;
3722     _ckvmssts(sys$setast(1));
3723     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3724      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
3725      * have SYS$COMMAND if we need it.
3726      */
3727     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3728                       0, &info->pid, &info->completion,
3729                       0, popen_completion_ast,info,0,0,0));
3730
3731     /* if we were using a tempfile, close it now */
3732
3733     if (tpipe) fclose(tpipe);
3734
3735     /* once the subprocess is spawned, it has copied the symbols and
3736        we can get rid of ours */
3737
3738     for (j = 0; j < 4; j++) {
3739         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3740         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3741     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3742     }
3743     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
3744     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3745     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3746     vms_execfree(vmscmd);
3747
3748 #ifdef PERL_IMPLICIT_CONTEXT
3749     if (aTHX)
3750 #endif
3751     PL_forkprocess = info->pid;
3752
3753     if (wait) {
3754          int done = 0;
3755          while (!done) {
3756              _ckvmssts(sys$setast(0));
3757              done = info->done;
3758              if (!done) _ckvmssts(sys$clref(pipe_ef));
3759              _ckvmssts(sys$setast(1));
3760              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3761          }
3762         *psts = info->completion;
3763 /* Caller thinks it is open and tries to close it. */
3764 /* This causes some problems, as it changes the error status */
3765 /*        my_pclose(info->fp); */
3766     } else {
3767         *psts = SS$_NORMAL;
3768     }
3769     return info->fp;
3770 }  /* end of safe_popen */
3771
3772
3773 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
3774 PerlIO *
3775 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3776 {
3777     int sts;
3778     TAINT_ENV();
3779     TAINT_PROPER("popen");
3780     PERL_FLUSHALL_FOR_CHILD;
3781     return safe_popen(aTHX_ cmd,mode,&sts);
3782 }
3783
3784 /*}}}*/
3785
3786 /*{{{  I32 my_pclose(PerlIO *fp)*/
3787 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3788 {
3789     pInfo info, last = NULL;
3790     unsigned long int retsts;
3791     int done, iss, n;
3792
3793     for (info = open_pipes; info != NULL; last = info, info = info->next)
3794         if (info->fp == fp) break;
3795
3796     if (info == NULL) {  /* no such pipe open */
3797       set_errno(ECHILD); /* quoth POSIX */
3798       set_vaxc_errno(SS$_NONEXPR);
3799       return -1;
3800     }
3801
3802     /* If we were writing to a subprocess, insure that someone reading from
3803      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
3804      * produce an EOF record in the mailbox.
3805      *
3806      *  well, at least sometimes it *does*, so we have to watch out for
3807      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
3808      */
3809      if (info->fp) {
3810         if (!info->useFILE)
3811             PerlIO_flush(info->fp);   /* first, flush data */
3812         else
3813             fflush((FILE *)info->fp);
3814     }
3815
3816     _ckvmssts(sys$setast(0));
3817      info->closing = TRUE;
3818      done = info->done && info->in_done && info->out_done && info->err_done;
3819      /* hanging on write to Perl's input? cancel it */
3820      if (info->mode == 'r' && info->out && !info->out_done) {
3821         if (info->out->chan_out) {
3822             _ckvmssts(sys$cancel(info->out->chan_out));
3823             if (!info->out->chan_in) {   /* EOF generation, need AST */
3824                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3825             }
3826         }
3827      }
3828      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
3829          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3830                            0, 0, 0, 0, 0, 0));
3831     _ckvmssts(sys$setast(1));
3832     if (info->fp) {
3833      if (!info->useFILE)
3834         PerlIO_close(info->fp);
3835      else
3836         fclose((FILE *)info->fp);
3837     }
3838      /*
3839         we have to wait until subprocess completes, but ALSO wait until all
3840         the i/o completes...otherwise we'll be freeing the "info" structure
3841         that the i/o ASTs could still be using...
3842      */
3843
3844      while (!done) {
3845          _ckvmssts(sys$setast(0));
3846          done = info->done && info->in_done && info->out_done && info->err_done;
3847          if (!done) _ckvmssts(sys$clref(pipe_ef));
3848          _ckvmssts(sys$setast(1));
3849          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3850      }
3851      retsts = info->completion;
3852
3853     /* remove from list of open pipes */
3854     _ckvmssts(sys$setast(0));
3855     if (last) last->next = info->next;
3856     else open_pipes = info->next;
3857     _ckvmssts(sys$setast(1));
3858
3859     /* free buffers and structures */
3860
3861     if (info->in) {
3862         if (info->in->buf) {
3863             n = info->in->bufsize * sizeof(char);
3864             _ckvmssts(lib$free_vm(&n, &info->in->buf));
3865         }
3866         n = sizeof(Pipe);
3867         _ckvmssts(lib$free_vm(&n, &info->in));
3868     }
3869     if (info->out) {
3870         if (info->out->buf) {
3871             n = info->out->bufsize * sizeof(char);
3872             _ckvmssts(lib$free_vm(&n, &info->out->buf));
3873         }
3874         n = sizeof(Pipe);
3875         _ckvmssts(lib$free_vm(&n, &info->out));
3876     }
3877     if (info->err) {
3878         if (info->err->buf) {
3879             n = info->err->bufsize * sizeof(char);
3880             _ckvmssts(lib$free_vm(&n, &info->err->buf));
3881         }
3882         n = sizeof(Pipe);
3883         _ckvmssts(lib$free_vm(&n, &info->err));
3884     }
3885     n = sizeof(Info);
3886     _ckvmssts(lib$free_vm(&n, &info));
3887
3888     return retsts;
3889
3890 }  /* end of my_pclose() */
3891
3892 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3893   /* Roll our own prototype because we want this regardless of whether
3894    * _VMS_WAIT is defined.
3895    */
3896   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3897 #endif
3898 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3899    created with popen(); otherwise partially emulate waitpid() unless
3900    we have a suitable one from the CRTL that came with VMS 7.2 and later.
3901    Also check processes not considered by the CRTL waitpid().
3902  */
3903 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3904 Pid_t
3905 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3906 {
3907     pInfo info;
3908     int done;
3909     int sts;
3910     int j;
3911
3912     if (statusp) *statusp = 0;
3913
3914     for (info = open_pipes; info != NULL; info = info->next)
3915         if (info->pid == pid) break;
3916
3917     if (info != NULL) {  /* we know about this child */
3918       while (!info->done) {
3919           _ckvmssts(sys$setast(0));
3920           done = info->done;
3921           if (!done) _ckvmssts(sys$clref(pipe_ef));
3922           _ckvmssts(sys$setast(1));
3923           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3924       }
3925
3926       if (statusp) *statusp = info->completion;
3927       return pid;
3928     }
3929
3930     /* child that already terminated? */
3931
3932     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3933         if (closed_list[j].pid == pid) {
3934             if (statusp) *statusp = closed_list[j].completion;
3935             return pid;
3936         }
3937     }
3938
3939     /* fall through if this child is not one of our own pipe children */
3940
3941 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3942
3943       /* waitpid() became available in the CRTL as of VMS 7.0, but only
3944        * in 7.2 did we get a version that fills in the VMS completion
3945        * status as Perl has always tried to do.
3946        */
3947
3948       sts = __vms_waitpid( pid, statusp, flags );
3949
3950       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3951          return sts;
3952
3953       /* If the real waitpid tells us the child does not exist, we
3954        * fall through here to implement waiting for a child that
3955        * was created by some means other than exec() (say, spawned
3956        * from DCL) or to wait for a process that is not a subprocess
3957        * of the current process.
3958        */
3959
3960 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3961
3962     {
3963       $DESCRIPTOR(intdsc,"0 00:00:01");
3964       unsigned long int ownercode = JPI$_OWNER, ownerpid;
3965       unsigned long int pidcode = JPI$_PID, mypid;
3966       unsigned long int interval[2];
3967       unsigned int jpi_iosb[2];
3968       struct itmlst_3 jpilist[2] = {
3969           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
3970           {                      0,         0,                 0, 0}
3971       };
3972
3973       if (pid <= 0) {
3974         /* Sorry folks, we don't presently implement rooting around for
3975            the first child we can find, and we definitely don't want to
3976            pass a pid of -1 to $getjpi, where it is a wildcard operation.
3977          */
3978         set_errno(ENOTSUP);
3979         return -1;
3980       }
3981
3982       /* Get the owner of the child so I can warn if it's not mine. If the
3983        * process doesn't exist or I don't have the privs to look at it,
3984        * I can go home early.
3985        */
3986       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3987       if (sts & 1) sts = jpi_iosb[0];
3988       if (!(sts & 1)) {
3989         switch (sts) {
3990             case SS$_NONEXPR:
3991                 set_errno(ECHILD);
3992                 break;
3993             case SS$_NOPRIV:
3994                 set_errno(EACCES);
3995                 break;
3996             default:
3997                 _ckvmssts(sts);
3998         }
3999         set_vaxc_errno(sts);
4000         return -1;
4001       }
4002
4003       if (ckWARN(WARN_EXEC)) {
4004         /* remind folks they are asking for non-standard waitpid behavior */
4005         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4006         if (ownerpid != mypid)
4007           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4008                       "waitpid: process %x is not a child of process %x",
4009                       pid,mypid);
4010       }
4011
4012       /* simply check on it once a second until it's not there anymore. */
4013
4014       _ckvmssts(sys$bintim(&intdsc,interval));
4015       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4016             _ckvmssts(sys$schdwk(0,0,interval,0));
4017             _ckvmssts(sys$hiber());
4018       }
4019       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4020
4021       _ckvmssts(sts);
4022       return pid;
4023     }
4024 }  /* end of waitpid() */
4025 /*}}}*/
4026 /*}}}*/
4027 /*}}}*/
4028
4029 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4030 char *
4031 my_gconvert(double val, int ndig, int trail, char *buf)
4032 {
4033   static char __gcvtbuf[DBL_DIG+1];
4034   char *loc;
4035
4036   loc = buf ? buf : __gcvtbuf;
4037
4038 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4039   if (val < 1) {
4040     sprintf(loc,"%.*g",ndig,val);
4041     return loc;
4042   }
4043 #endif
4044
4045   if (val) {
4046     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4047     return gcvt(val,ndig,loc);
4048   }
4049   else {
4050     loc[0] = '0'; loc[1] = '\0';
4051     return loc;
4052   }
4053
4054 }
4055 /*}}}*/
4056
4057 #if 1 /* defined(__VAX) || !defined(NAML$C_MAXRSS) */
4058 static int rms_free_search_context(struct FAB * fab)
4059 {
4060 struct NAM * nam;
4061
4062     nam = fab->fab$l_nam;
4063     nam->nam$b_nop |= NAM$M_SYNCHK;
4064     nam->nam$l_rlf = NULL;
4065     fab->fab$b_dns = 0;
4066     return sys$parse(fab, NULL, NULL);
4067 }
4068
4069 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4070 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4071 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4072 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4073 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4074 #define rms_nam_esll(nam) nam.nam$b_esl
4075 #define rms_nam_esl(nam) nam.nam$b_esl
4076 #define rms_nam_name(nam) nam.nam$l_name
4077 #define rms_nam_namel(nam) nam.nam$l_name
4078 #define rms_nam_type(nam) nam.nam$l_type
4079 #define rms_nam_typel(nam) nam.nam$l_type
4080 #define rms_nam_ver(nam) nam.nam$l_ver
4081 #define rms_nam_verl(nam) nam.nam$l_ver
4082 #define rms_nam_rsll(nam) nam.nam$b_rsl
4083 #define rms_nam_rsl(nam) nam.nam$b_rsl
4084 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4085 #define rms_set_fna(fab, nam, name, size) \
4086         fab.fab$b_fns = size; fab.fab$l_fna = name;
4087 #define rms_get_fna(fab, nam) fab.fab$l_fna
4088 #define rms_set_dna(fab, nam, name, size) \
4089         fab.fab$b_dns = size; fab.fab$l_dna = name;
4090 #define rms_nam_dns(fab, nam) fab.fab$b_dns;
4091 #define rms_set_esa(fab, nam, name, size) \
4092         nam.nam$b_ess = size; nam.nam$l_esa = name;
4093 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4094         nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
4095 #define rms_set_rsa(nam, name, size) \
4096         nam.nam$l_rsa = name; nam.nam$b_rss = size;
4097 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4098         nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
4099
4100 #else
4101 static int rms_free_search_context(struct FAB * fab)
4102 {
4103 struct NAML * nam;
4104
4105     nam = fab->fab$l_naml;
4106     nam->naml$b_nop |= NAM$M_SYNCHK;
4107     nam->naml$l_rlf = NULL;
4108     nam->naml$l_long_defname_size = 0;
4109     fab->fab$b_dns = 0;
4110     return sys$parse(fab, NULL, NULL);
4111 }
4112
4113 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4114 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4115 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4116 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4117 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4118 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4119 #define rms_nam_esl(nam) nam.naml$b_esl
4120 #define rms_nam_name(nam) nam.naml$l_name
4121 #define rms_nam_namel(nam) nam.naml$l_long_name
4122 #define rms_nam_type(nam) nam.naml$l_type
4123 #define rms_nam_typel(nam) nam.naml$l_long_type
4124 #define rms_nam_ver(nam) nam.naml$l_ver
4125 #define rms_nam_verl(nam) nam.naml$l_long_ver
4126 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4127 #define rms_nam_rsl(nam) nam.naml$b_rsl
4128 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4129 #define rms_set_fna(fab, nam, name, size) \
4130         fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4131         nam.naml$l_long_filename_size = size; \
4132         nam.naml$l_long_filename = name
4133 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4134 #define rms_set_dna(fab, nam, name, size) \
4135         fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4136         nam.naml$l_long_defname_size = size; \
4137         nam.naml$l_long_defname = name
4138 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4139 #define rms_set_esa(fab, nam, name, size) \
4140         nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4141         nam.naml$l_long_expand_alloc = size; \
4142         nam.naml$l_long_expand = name
4143 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4144         nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4145         nam.naml$l_long_expand = l_name; \
4146         nam.naml$l_long_expand_alloc = l_size;
4147 #define rms_set_rsa(nam, name, size) \
4148         nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4149         nam.naml$l_long_result = name; \
4150         nam.naml$l_long_result_alloc = size;
4151 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4152         nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4153         nam.naml$l_long_result = l_name; \
4154         nam.naml$l_long_result_alloc = l_size;
4155
4156 #endif
4157
4158
4159 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4160 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4161  * to expand file specification.  Allows for a single default file
4162  * specification and a simple mask of options.  If outbuf is non-NULL,
4163  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4164  * the resultant file specification is placed.  If outbuf is NULL, the
4165  * resultant file specification is placed into a static buffer.
4166  * The third argument, if non-NULL, is taken to be a default file
4167  * specification string.  The fourth argument is unused at present.
4168  * rmesexpand() returns the address of the resultant string if
4169  * successful, and NULL on error.
4170  *
4171  * New functionality for previously unused opts value:
4172  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4173  */
4174 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
4175
4176 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4177 /* ODS-2 only version */
4178 static char *
4179 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4180 {
4181   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
4182   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
4183   char esa[NAM$C_MAXRSS+1], *cp, *out = NULL;
4184   struct FAB myfab = cc$rms_fab;
4185   struct NAM mynam = cc$rms_nam;
4186   STRLEN speclen;
4187   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4188   int sts;
4189
4190   if (!filespec || !*filespec) {
4191     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4192     return NULL;
4193   }
4194   if (!outbuf) {
4195     if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
4196     else    outbuf = __rmsexpand_retbuf;
4197   }
4198   isunix = is_unix_filespec(filespec);
4199   if (isunix) {
4200     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4201         if (out)
4202            Safefree(out);
4203         return NULL;
4204     }
4205     filespec = vmsfspec;
4206   }
4207
4208   myfab.fab$l_fna = (char *)filespec;  /* cast ok for read only pointer */
4209   myfab.fab$b_fns = strlen(filespec);
4210   myfab.fab$l_nam = &mynam;
4211
4212   if (defspec && *defspec) {
4213     if (strchr(defspec,'/') != NULL) {
4214       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4215         if (out)
4216            Safefree(out);
4217         return NULL;
4218       }
4219       defspec = tmpfspec;
4220     }
4221     myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
4222     myfab.fab$b_dns = strlen(defspec);
4223   }
4224
4225   mynam.nam$l_esa = esa;
4226   mynam.nam$b_ess = NAM$C_MAXRSS;
4227   mynam.nam$l_rsa = outbuf;
4228   mynam.nam$b_rss = NAM$C_MAXRSS;
4229
4230 #ifdef NAM$M_NO_SHORT_UPCASE
4231   if (decc_efs_case_preserve)
4232     mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4233 #endif
4234
4235   retsts = sys$parse(&myfab,0,0);
4236   if (!(retsts & 1)) {
4237     mynam.nam$b_nop |= NAM$M_SYNCHK;
4238     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4239       retsts = sys$parse(&myfab,0,0);
4240       if (retsts & 1) goto expanded;
4241     }
4242     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
4243     sts = sys$parse(&myfab,0,0);  /* Free search context */
4244     if (out) Safefree(out);
4245     set_vaxc_errno(retsts);
4246     if      (retsts == RMS$_PRV) set_errno(EACCES);
4247     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4248     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4249     else                         set_errno(EVMSERR);
4250     return NULL;
4251   }
4252   retsts = sys$search(&myfab,0,0);
4253   if (!(retsts & 1) && retsts != RMS$_FNF) {
4254     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4255     myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
4256     if (out) Safefree(out);
4257     set_vaxc_errno(retsts);
4258     if      (retsts == RMS$_PRV) set_errno(EACCES);
4259     else                         set_errno(EVMSERR);
4260     return NULL;
4261   }
4262
4263   /* If the input filespec contained any lowercase characters,
4264    * downcase the result for compatibility with Unix-minded code. */
4265   expanded:
4266   if (!decc_efs_case_preserve) {
4267     for (out = myfab.fab$l_fna; *out; out++)
4268       if (islower(*out)) { haslower = 1; break; }
4269   }
4270   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
4271   else                 { out = esa;    speclen = mynam.nam$b_esl; }
4272   out[speclen] = 0;
4273   /* Trim off null fields added by $PARSE
4274    * If type > 1 char, must have been specified in original or default spec
4275    * (not true for version; $SEARCH may have added version of existing file).
4276    */
4277   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
4278   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
4279              (mynam.nam$l_ver - mynam.nam$l_type == 1);
4280   if (trimver || trimtype) {
4281     if (defspec && *defspec) {
4282       char defesa[NAM$C_MAXRSS];
4283       struct FAB deffab = cc$rms_fab;
4284       struct NAM defnam = cc$rms_nam;
4285
4286       deffab.fab$l_nam = &defnam;
4287       /* cast below ok for read only pointer */
4288       deffab.fab$l_fna = (char *)defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
4289       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = NAM$C_MAXRSS;
4290       defnam.nam$b_nop = NAM$M_SYNCHK;
4291 #ifdef NAM$M_NO_SHORT_UPCASE
4292       if (decc_efs_case_preserve)
4293         defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4294 #endif
4295       if (sys$parse(&deffab,0,0) & 1) {
4296         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
4297         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4298       }
4299     }
4300     if (trimver) {
4301       if (*mynam.nam$l_ver != '\"')
4302         speclen = mynam.nam$l_ver - out;
4303     }
4304     if (trimtype) {
4305       /* If we didn't already trim version, copy down */
4306       if (speclen > mynam.nam$l_ver - out)
4307         memmove(mynam.nam$l_type, mynam.nam$l_ver,
4308                speclen - (mynam.nam$l_ver - out));
4309       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4310     }
4311   }
4312   /* If we just had a directory spec on input, $PARSE "helpfully"
4313    * adds an empty name and type for us */
4314   if (mynam.nam$l_name == mynam.nam$l_type &&
4315       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
4316       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4317     speclen = mynam.nam$l_name - out;
4318
4319   /* Posix format specifications must have matching quotes */
4320   if (speclen < NAM$C_MAXRSS) {
4321     if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4322       if ((speclen > 1) && (out[speclen-1] != '\"')) {
4323         out[speclen] = '\"';
4324         speclen++;
4325       }
4326     }
4327   }
4328
4329   out[speclen] = '\0';
4330   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4331
4332   /* Have we been working with an expanded, but not resultant, spec? */
4333   /* Also, convert back to Unix syntax if necessary. */
4334   if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4335     isunix = 0;
4336
4337   if (!mynam.nam$b_rsl) {
4338     if (isunix) {
4339       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4340     }
4341     else strcpy(outbuf,esa);
4342   }
4343   else if (isunix) {
4344     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4345     strcpy(outbuf,tmpfspec);
4346   }
4347   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4348   mynam.nam$l_rsa = NULL;
4349   mynam.nam$b_rss = 0;
4350   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);  /* Free search context */
4351   return outbuf;
4352 }
4353 #else
4354 /* ODS-5 supporting routine */
4355 static char *
4356 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4357 {
4358   static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4359   char * vmsfspec, *tmpfspec;
4360   char * esa, *cp, *out = NULL;
4361   char * tbuf;
4362   char * esal;
4363   char * outbufl;
4364   struct FAB myfab = cc$rms_fab;
4365   rms_setup_nam(mynam);
4366   STRLEN speclen;
4367   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4368   int sts;
4369
4370   if (!filespec || !*filespec) {
4371     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4372     return NULL;
4373   }
4374   if (!outbuf) {
4375     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4376     else    outbuf = __rmsexpand_retbuf;
4377   }
4378
4379   vmsfspec = NULL;
4380   tmpfspec = NULL;
4381   outbufl = NULL;
4382   isunix = is_unix_filespec(filespec);
4383   if (isunix) {
4384     vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4385     if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4386     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4387         PerlMem_free(vmsfspec);
4388         if (out)
4389            Safefree(out);
4390         return NULL;
4391     }
4392     filespec = vmsfspec;
4393
4394      /* Unless we are forcing to VMS format, a UNIX input means
4395       * UNIX output, and that requires long names to be used
4396       */
4397     if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4398         opts |= PERL_RMSEXPAND_M_LONG;
4399     else {
4400         isunix = 0;
4401     }
4402   }
4403
4404   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4405   rms_bind_fab_nam(myfab, mynam);
4406
4407   if (defspec && *defspec) {
4408     int t_isunix;
4409     t_isunix = is_unix_filespec(defspec);
4410     if (t_isunix) {
4411       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4412       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4413       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4414         PerlMem_free(tmpfspec);
4415         if (vmsfspec != NULL)
4416             PerlMem_free(vmsfspec);
4417         if (out)
4418            Safefree(out);
4419         return NULL;
4420       }
4421       defspec = tmpfspec;
4422     }
4423     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4424   }
4425
4426   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4427   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4428 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4429   esal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4430   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4431 #endif
4432   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
4433
4434   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4435     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4436   }
4437   else {
4438 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4439     outbufl = PerlMem_malloc(VMS_MAXRSS);
4440     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4441     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4442 #else
4443     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4444 #endif
4445   }
4446
4447 #ifdef NAM$M_NO_SHORT_UPCASE
4448   if (decc_efs_case_preserve)
4449     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4450 #endif
4451
4452   /* First attempt to parse as an existing file */
4453   retsts = sys$parse(&myfab,0,0);
4454   if (!(retsts & STS$K_SUCCESS)) {
4455
4456     /* Could not find the file, try as syntax only if error is not fatal */
4457     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4458     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4459       retsts = sys$parse(&myfab,0,0);
4460       if (retsts & STS$K_SUCCESS) goto expanded;
4461     }
4462
4463      /* Still could not parse the file specification */
4464     /*----------------------------------------------*/
4465     sts = rms_free_search_context(&myfab); /* Free search context */
4466     if (out) Safefree(out);
4467     if (tmpfspec != NULL)
4468         PerlMem_free(tmpfspec);
4469     if (vmsfspec != NULL)
4470         PerlMem_free(vmsfspec);
4471     if (outbufl != NULL)
4472         PerlMem_free(outbufl);
4473     PerlMem_free(esa);
4474     PerlMem_free(esal);
4475     set_vaxc_errno(retsts);
4476     if      (retsts == RMS$_PRV) set_errno(EACCES);
4477     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4478     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4479     else                         set_errno(EVMSERR);
4480     return NULL;
4481   }
4482   retsts = sys$search(&myfab,0,0);
4483   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4484     sts = rms_free_search_context(&myfab); /* Free search context */
4485     if (out) Safefree(out);
4486     if (tmpfspec != NULL)
4487         PerlMem_free(tmpfspec);
4488     if (vmsfspec != NULL)
4489         PerlMem_free(vmsfspec);
4490     if (outbufl != NULL)
4491         PerlMem_free(outbufl);
4492     PerlMem_free(esa);
4493     PerlMem_free(esal);
4494     set_vaxc_errno(retsts);
4495     if      (retsts == RMS$_PRV) set_errno(EACCES);
4496     else                         set_errno(EVMSERR);
4497     return NULL;
4498   }
4499
4500   /* If the input filespec contained any lowercase characters,
4501    * downcase the result for compatibility with Unix-minded code. */
4502   expanded:
4503   if (!decc_efs_case_preserve) {
4504     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4505       if (islower(*tbuf)) { haslower = 1; break; }
4506   }
4507
4508    /* Is a long or a short name expected */
4509   /*------------------------------------*/
4510   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4511     if (rms_nam_rsll(mynam)) {
4512         tbuf = outbuf;
4513         speclen = rms_nam_rsll(mynam);
4514     }
4515     else {
4516         tbuf = esal; /* Not esa */
4517         speclen = rms_nam_esll(mynam);
4518     }
4519   }
4520   else {
4521     if (rms_nam_rsl(mynam)) {
4522         tbuf = outbuf;
4523         speclen = rms_nam_rsl(mynam);
4524     }
4525     else {
4526         tbuf = esa; /* Not esal */
4527         speclen = rms_nam_esl(mynam);
4528     }
4529   }
4530   tbuf[speclen] = '\0';
4531
4532   /* Trim off null fields added by $PARSE
4533    * If type > 1 char, must have been specified in original or default spec
4534    * (not true for version; $SEARCH may have added version of existing file).
4535    */
4536   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4537   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4538     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4539              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4540   }
4541   else {
4542     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4543              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4544   }
4545   if (trimver || trimtype) {
4546     if (defspec && *defspec) {
4547       char *defesal = NULL;
4548       defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4549       if (defesal != NULL) {
4550         struct FAB deffab = cc$rms_fab;
4551         rms_setup_nam(defnam);
4552
4553         rms_bind_fab_nam(deffab, defnam);
4554
4555         /* Cast ok */
4556         rms_set_fna
4557             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4558
4559         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4560
4561         rms_clear_nam_nop(defnam);
4562         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4563 #ifdef NAM$M_NO_SHORT_UPCASE
4564         if (decc_efs_case_preserve)
4565           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4566 #endif
4567         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4568           if (trimver) {
4569              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4570           }
4571           if (trimtype) {
4572             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4573           }
4574         }
4575         PerlMem_free(defesal);
4576       }
4577     }
4578     if (trimver) {
4579       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4580         if (*(rms_nam_verl(mynam)) != '\"')
4581           speclen = rms_nam_verl(mynam) - tbuf;
4582       }
4583       else {
4584         if (*(rms_nam_ver(mynam)) != '\"')
4585           speclen = rms_nam_ver(mynam) - tbuf;
4586       }
4587     }
4588     if (trimtype) {
4589       /* If we didn't already trim version, copy down */
4590       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4591         if (speclen > rms_nam_verl(mynam) - tbuf)
4592           memmove
4593            (rms_nam_typel(mynam),
4594             rms_nam_verl(mynam),
4595             speclen - (rms_nam_verl(mynam) - tbuf));
4596           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4597       }
4598       else {
4599         if (speclen > rms_nam_ver(mynam) - tbuf)
4600           memmove
4601            (rms_nam_type(mynam),
4602             rms_nam_ver(mynam),
4603             speclen - (rms_nam_ver(mynam) - tbuf));
4604           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4605       }
4606     }
4607   }
4608
4609    /* Done with these copies of the input files */
4610   /*-------------------------------------------*/
4611   if (vmsfspec != NULL)
4612         PerlMem_free(vmsfspec);
4613   if (tmpfspec != NULL)
4614         PerlMem_free(tmpfspec);
4615
4616   /* If we just had a directory spec on input, $PARSE "helpfully"
4617    * adds an empty name and type for us */
4618   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4619     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4620         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
4621         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4622       speclen = rms_nam_namel(mynam) - tbuf;
4623   }
4624   else {
4625     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4626         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
4627         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4628       speclen = rms_nam_name(mynam) - tbuf;
4629   }
4630
4631   /* Posix format specifications must have matching quotes */
4632   if (speclen < (VMS_MAXRSS - 1)) {
4633     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4634       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4635         tbuf[speclen] = '\"';
4636         speclen++;
4637       }
4638     }
4639   }
4640   tbuf[speclen] = '\0';
4641   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4642
4643   /* Have we been working with an expanded, but not resultant, spec? */
4644   /* Also, convert back to Unix syntax if necessary. */
4645
4646   if (!rms_nam_rsll(mynam)) {
4647     if (isunix) {
4648       if (do_tounixspec(esa,outbuf,0) == NULL) {
4649         if (out) Safefree(out);
4650         PerlMem_free(esal);
4651         PerlMem_free(esa);
4652         if (outbufl != NULL)
4653             PerlMem_free(outbufl);
4654         return NULL;
4655       }
4656     }
4657     else strcpy(outbuf,esa);
4658   }
4659   else if (isunix) {
4660     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4661     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4662     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4663         if (out) Safefree(out);
4664         PerlMem_free(esa);
4665         PerlMem_free(esal);
4666         PerlMem_free(tmpfspec);
4667         if (outbufl != NULL)
4668             PerlMem_free(outbufl);
4669         return NULL;
4670     }
4671     strcpy(outbuf,tmpfspec);
4672     PerlMem_free(tmpfspec);
4673   }
4674
4675   rms_set_rsal(mynam, NULL, 0, NULL, 0);
4676   sts = rms_free_search_context(&myfab); /* Free search context */
4677   PerlMem_free(esa);
4678   PerlMem_free(esal);
4679   if (outbufl != NULL)
4680      PerlMem_free(outbufl);
4681   return outbuf;
4682 }
4683 #endif
4684 /*}}}*/
4685 /* External entry points */
4686 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4687 { return do_rmsexpand(spec,buf,0,def,opt); }
4688 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4689 { return do_rmsexpand(spec,buf,1,def,opt); }
4690
4691
4692 /*
4693 ** The following routines are provided to make life easier when
4694 ** converting among VMS-style and Unix-style directory specifications.
4695 ** All will take input specifications in either VMS or Unix syntax. On
4696 ** failure, all return NULL.  If successful, the routines listed below
4697 ** return a pointer to a buffer containing the appropriately
4698 ** reformatted spec (and, therefore, subsequent calls to that routine
4699 ** will clobber the result), while the routines of the same names with
4700 ** a _ts suffix appended will return a pointer to a mallocd string
4701 ** containing the appropriately reformatted spec.
4702 ** In all cases, only explicit syntax is altered; no check is made that
4703 ** the resulting string is valid or that the directory in question
4704 ** actually exists.
4705 **
4706 **   fileify_dirspec() - convert a directory spec into the name of the
4707 **     directory file (i.e. what you can stat() to see if it's a dir).
4708 **     The style (VMS or Unix) of the result is the same as the style
4709 **     of the parameter passed in.
4710 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4711 **     what you prepend to a filename to indicate what directory it's in).
4712 **     The style (VMS or Unix) of the result is the same as the style
4713 **     of the parameter passed in.
4714 **   tounixpath() - convert a directory spec into a Unix-style path.
4715 **   tovmspath() - convert a directory spec into a VMS-style path.
4716 **   tounixspec() - convert any file spec into a Unix-style file spec.
4717 **   tovmsspec() - convert any file spec into a VMS-style spec.
4718 **
4719 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4720 ** Permission is given to distribute this code as part of the Perl
4721 ** standard distribution under the terms of the GNU General Public
4722 ** License or the Perl Artistic License.  Copies of each may be
4723 ** found in the Perl standard distribution.
4724  */
4725
4726 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4727 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4728 {
4729     static char __fileify_retbuf[VMS_MAXRSS];
4730     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4731     char *retspec, *cp1, *cp2, *lastdir;
4732     char *trndir, *vmsdir;
4733     unsigned short int trnlnm_iter_count;
4734     int sts;
4735
4736     if (!dir || !*dir) {
4737       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4738     }
4739     dirlen = strlen(dir);
4740     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4741     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4742       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4743         dir = "/sys$disk";
4744         dirlen = 9;
4745       }
4746       else
4747         dirlen = 1;
4748     }
4749     if (dirlen > (VMS_MAXRSS - 1)) {
4750       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4751       return NULL;
4752     }
4753     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4754     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4755     if (!strpbrk(dir+1,"/]>:")  &&
4756         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4757       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4758       trnlnm_iter_count = 0;
4759       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4760         trnlnm_iter_count++;
4761         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4762       }
4763       dirlen = strlen(trndir);
4764     }
4765     else {
4766       strncpy(trndir,dir,dirlen);
4767       trndir[dirlen] = '\0';
4768     }
4769
4770     /* At this point we are done with *dir and use *trndir which is a
4771      * copy that can be modified.  *dir must not be modified.
4772      */
4773
4774     /* If we were handed a rooted logical name or spec, treat it like a
4775      * simple directory, so that
4776      *    $ Define myroot dev:[dir.]
4777      *    ... do_fileify_dirspec("myroot",buf,1) ...
4778      * does something useful.
4779      */
4780     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4781       trndir[--dirlen] = '\0';
4782       trndir[dirlen-1] = ']';
4783     }
4784     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4785       trndir[--dirlen] = '\0';
4786       trndir[dirlen-1] = '>';
4787     }
4788
4789     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4790       /* If we've got an explicit filename, we can just shuffle the string. */
4791       if (*(cp1+1)) hasfilename = 1;
4792       /* Similarly, we can just back up a level if we've got multiple levels
4793          of explicit directories in a VMS spec which ends with directories. */
4794       else {
4795         for (cp2 = cp1; cp2 > trndir; cp2--) {
4796           if (*cp2 == '.') {
4797             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4798 /* fix-me, can not scan EFS file specs backward like this */
4799               *cp2 = *cp1; *cp1 = '\0';
4800               hasfilename = 1;
4801               break;
4802             }
4803           }
4804           if (*cp2 == '[' || *cp2 == '<') break;
4805         }
4806       }
4807     }
4808
4809     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4810     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4811     cp1 = strpbrk(trndir,"]:>");
4812     if (hasfilename || !cp1) { /* Unix-style path or filename */
4813       if (trndir[0] == '.') {
4814         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4815           PerlMem_free(trndir);
4816           PerlMem_free(vmsdir);
4817           return do_fileify_dirspec("[]",buf,ts);
4818         }
4819         else if (trndir[1] == '.' &&
4820                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4821           PerlMem_free(trndir);
4822           PerlMem_free(vmsdir);
4823           return do_fileify_dirspec("[-]",buf,ts);
4824         }
4825       }
4826       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4827         dirlen -= 1;                 /* to last element */
4828         lastdir = strrchr(trndir,'/');
4829       }
4830       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4831         /* If we have "/." or "/..", VMSify it and let the VMS code
4832          * below expand it, rather than repeating the code to handle
4833          * relative components of a filespec here */
4834         do {
4835           if (*(cp1+2) == '.') cp1++;
4836           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4837             char * ret_chr;
4838             if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4839                 PerlMem_free(trndir);
4840                 PerlMem_free(vmsdir);
4841                 return NULL;
4842             }
4843             if (strchr(vmsdir,'/') != NULL) {
4844               /* If do_tovmsspec() returned it, it must have VMS syntax
4845                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
4846                * the time to check this here only so we avoid a recursion
4847                * loop; otherwise, gigo.
4848                */
4849               PerlMem_free(trndir);
4850               PerlMem_free(vmsdir);
4851               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
4852               return NULL;
4853             }
4854             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4855                 PerlMem_free(trndir);
4856                 PerlMem_free(vmsdir);
4857                 return NULL;
4858             }
4859             ret_chr = do_tounixspec(trndir,buf,ts);
4860             PerlMem_free(trndir);
4861             PerlMem_free(vmsdir);
4862             return ret_chr;
4863           }
4864           cp1++;
4865         } while ((cp1 = strstr(cp1,"/.")) != NULL);
4866         lastdir = strrchr(trndir,'/');
4867       }
4868       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4869         char * ret_chr;
4870         /* Ditto for specs that end in an MFD -- let the VMS code
4871          * figure out whether it's a real device or a rooted logical. */
4872
4873         /* This should not happen any more.  Allowing the fake /000000
4874          * in a UNIX pathname causes all sorts of problems when trying
4875          * to run in UNIX emulation.  So the VMS to UNIX conversions
4876          * now remove the fake /000000 directories.
4877          */
4878
4879         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4880         if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4881             PerlMem_free(trndir);
4882             PerlMem_free(vmsdir);
4883             return NULL;
4884         }
4885         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4886             PerlMem_free(trndir);
4887             PerlMem_free(vmsdir);
4888             return NULL;
4889         }
4890         ret_chr = do_tounixspec(trndir,buf,ts);
4891         PerlMem_free(trndir);
4892         PerlMem_free(vmsdir);
4893         return ret_chr;
4894       }
4895       else {
4896
4897         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4898              !(lastdir = cp1 = strrchr(trndir,']')) &&
4899              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4900         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
4901           int ver; char *cp3;
4902
4903           /* For EFS or ODS-5 look for the last dot */
4904           if (decc_efs_charset) {
4905               cp2 = strrchr(cp1,'.');
4906           }
4907           if (vms_process_case_tolerant) {
4908               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4909                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4910                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4911                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4912                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4913                             (ver || *cp3)))))) {
4914                   PerlMem_free(trndir);
4915                   PerlMem_free(vmsdir);
4916                   set_errno(ENOTDIR);
4917                   set_vaxc_errno(RMS$_DIR);
4918                   return NULL;
4919               }
4920           }
4921           else {
4922               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4923                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4924                   !*(cp2+3) || *(cp2+3) != 'R' ||
4925                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4926                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4927                             (ver || *cp3)))))) {
4928                  PerlMem_free(trndir);
4929                  PerlMem_free(vmsdir);
4930                  set_errno(ENOTDIR);
4931                  set_vaxc_errno(RMS$_DIR);
4932                  return NULL;
4933               }
4934           }
4935           dirlen = cp2 - trndir;
4936         }
4937       }
4938
4939       retlen = dirlen + 6;
4940       if (buf) retspec = buf;
4941       else if (ts) Newx(retspec,retlen+1,char);
4942       else retspec = __fileify_retbuf;
4943       memcpy(retspec,trndir,dirlen);
4944       retspec[dirlen] = '\0';
4945
4946       /* We've picked up everything up to the directory file name.
4947          Now just add the type and version, and we're set. */
4948       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4949         strcat(retspec,".dir;1");
4950       else
4951         strcat(retspec,".DIR;1");
4952       PerlMem_free(trndir);
4953       PerlMem_free(vmsdir);
4954       return retspec;
4955     }
4956     else {  /* VMS-style directory spec */
4957
4958       char *esa, term, *cp;
4959       unsigned long int sts, cmplen, haslower = 0;
4960       unsigned int nam_fnb;
4961       char * nam_type;
4962       struct FAB dirfab = cc$rms_fab;
4963       rms_setup_nam(savnam);
4964       rms_setup_nam(dirnam);
4965
4966       esa = PerlMem_malloc(VMS_MAXRSS + 1);
4967       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4968       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4969       rms_bind_fab_nam(dirfab, dirnam);
4970       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4971       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4972 #ifdef NAM$M_NO_SHORT_UPCASE
4973       if (decc_efs_case_preserve)
4974         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4975 #endif
4976
4977       for (cp = trndir; *cp; cp++)
4978         if (islower(*cp)) { haslower = 1; break; }
4979       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4980         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4981           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4982           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4983         }
4984         if (!sts) {
4985           PerlMem_free(esa);
4986           PerlMem_free(trndir);
4987           PerlMem_free(vmsdir);
4988           set_errno(EVMSERR);
4989           set_vaxc_errno(dirfab.fab$l_sts);
4990           return NULL;
4991         }
4992       }
4993       else {
4994         savnam = dirnam;
4995         /* Does the file really exist? */
4996         if (sys$search(&dirfab)& STS$K_SUCCESS) {
4997           /* Yes; fake the fnb bits so we'll check type below */
4998         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4999         }
5000         else { /* No; just work with potential name */
5001           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5002           else {
5003             int fab_sts;
5004             fab_sts = dirfab.fab$l_sts;
5005             sts = rms_free_search_context(&dirfab);
5006             PerlMem_free(esa);
5007             PerlMem_free(trndir);
5008             PerlMem_free(vmsdir);
5009             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5010             return NULL;
5011           }
5012         }
5013       }
5014       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5015         cp1 = strchr(esa,']');
5016         if (!cp1) cp1 = strchr(esa,'>');
5017         if (cp1) {  /* Should always be true */
5018           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5019           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5020         }
5021       }
5022       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5023         /* Yep; check version while we're at it, if it's there. */
5024         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5025         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5026           /* Something other than .DIR[;1].  Bzzt. */
5027           sts = rms_free_search_context(&dirfab);
5028           PerlMem_free(esa);
5029           PerlMem_free(trndir);
5030           PerlMem_free(vmsdir);
5031           set_errno(ENOTDIR);
5032           set_vaxc_errno(RMS$_DIR);
5033           return NULL;
5034         }
5035       }
5036       esa[rms_nam_esll(dirnam)] = '\0';
5037       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5038         /* They provided at least the name; we added the type, if necessary, */
5039         if (buf) retspec = buf;                            /* in sys$parse() */
5040         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5041         else retspec = __fileify_retbuf;
5042         strcpy(retspec,esa);
5043         sts = rms_free_search_context(&dirfab);
5044         PerlMem_free(trndir);
5045         PerlMem_free(esa);
5046         PerlMem_free(vmsdir);
5047         return retspec;
5048       }
5049       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5050         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5051         *cp1 = '\0';
5052         rms_nam_esll(dirnam) -= 9;
5053       }
5054       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5055       if (cp1 == NULL) { /* should never happen */
5056         sts = rms_free_search_context(&dirfab);
5057         PerlMem_free(trndir);
5058         PerlMem_free(esa);
5059         PerlMem_free(vmsdir);
5060         return NULL;
5061       }
5062       term = *cp1;
5063       *cp1 = '\0';
5064       retlen = strlen(esa);
5065       cp1 = strrchr(esa,'.');
5066       /* ODS-5 directory specifications can have extra "." in them. */
5067       /* Fix-me, can not scan EFS file specifications backwards */
5068       while (cp1 != NULL) {
5069         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5070           break;
5071         else {
5072            cp1--;
5073            while ((cp1 > esa) && (*cp1 != '.'))
5074              cp1--;
5075         }
5076         if (cp1 == esa)
5077           cp1 = NULL;
5078       }
5079
5080       if ((cp1) != NULL) {
5081         /* There's more than one directory in the path.  Just roll back. */
5082         *cp1 = term;
5083         if (buf) retspec = buf;
5084         else if (ts) Newx(retspec,retlen+7,char);
5085         else retspec = __fileify_retbuf;
5086         strcpy(retspec,esa);
5087       }
5088       else {
5089         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5090           /* Go back and expand rooted logical name */
5091           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5092 #ifdef NAM$M_NO_SHORT_UPCASE
5093           if (decc_efs_case_preserve)
5094             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5095 #endif
5096           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5097             sts = rms_free_search_context(&dirfab);
5098             PerlMem_free(esa);
5099             PerlMem_free(trndir);
5100             PerlMem_free(vmsdir);
5101             set_errno(EVMSERR);
5102             set_vaxc_errno(dirfab.fab$l_sts);
5103             return NULL;
5104           }
5105           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5106           if (buf) retspec = buf;
5107           else if (ts) Newx(retspec,retlen+16,char);
5108           else retspec = __fileify_retbuf;
5109           cp1 = strstr(esa,"][");
5110           if (!cp1) cp1 = strstr(esa,"]<");
5111           dirlen = cp1 - esa;
5112           memcpy(retspec,esa,dirlen);
5113           if (!strncmp(cp1+2,"000000]",7)) {
5114             retspec[dirlen-1] = '\0';
5115             /* fix-me Not full ODS-5, just extra dots in directories for now */
5116             cp1 = retspec + dirlen - 1;
5117             while (cp1 > retspec)
5118             {
5119               if (*cp1 == '[')
5120                 break;
5121               if (*cp1 == '.') {
5122                 if (*(cp1-1) != '^')
5123                   break;
5124               }
5125               cp1--;
5126             }
5127             if (*cp1 == '.') *cp1 = ']';
5128             else {
5129               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5130               memmove(cp1+1,"000000]",7);
5131             }
5132           }
5133           else {
5134             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5135             retspec[retlen] = '\0';
5136             /* Convert last '.' to ']' */
5137             cp1 = retspec+retlen-1;
5138             while (*cp != '[') {
5139               cp1--;
5140               if (*cp1 == '.') {
5141                 /* Do not trip on extra dots in ODS-5 directories */
5142                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5143                 break;
5144               }
5145             }
5146             if (*cp1 == '.') *cp1 = ']';
5147             else {
5148               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5149               memmove(cp1+1,"000000]",7);
5150             }
5151           }
5152         }
5153         else {  /* This is a top-level dir.  Add the MFD to the path. */
5154           if (buf) retspec = buf;
5155           else if (ts) Newx(retspec,retlen+16,char);
5156           else retspec = __fileify_retbuf;
5157           cp1 = esa;
5158           cp2 = retspec;
5159           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5160           strcpy(cp2,":[000000]");
5161           cp1 += 2;
5162           strcpy(cp2+9,cp1);
5163         }
5164       }
5165       sts = rms_free_search_context(&dirfab);
5166       /* We've set up the string up through the filename.  Add the
5167          type and version, and we're done. */
5168       strcat(retspec,".DIR;1");
5169
5170       /* $PARSE may have upcased filespec, so convert output to lower
5171        * case if input contained any lowercase characters. */
5172       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5173       PerlMem_free(trndir);
5174       PerlMem_free(esa);
5175       PerlMem_free(vmsdir);
5176       return retspec;
5177     }
5178 }  /* end of do_fileify_dirspec() */
5179 /*}}}*/
5180 /* External entry points */
5181 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5182 { return do_fileify_dirspec(dir,buf,0); }
5183 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5184 { return do_fileify_dirspec(dir,buf,1); }
5185
5186 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5187 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
5188 {
5189     static char __pathify_retbuf[VMS_MAXRSS];
5190     unsigned long int retlen;
5191     char *retpath, *cp1, *cp2, *trndir;
5192     unsigned short int trnlnm_iter_count;
5193     STRLEN trnlen;
5194     int sts;
5195
5196     if (!dir || !*dir) {
5197       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5198     }
5199
5200     trndir = PerlMem_malloc(VMS_MAXRSS);
5201     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5202     if (*dir) strcpy(trndir,dir);
5203     else getcwd(trndir,VMS_MAXRSS - 1);
5204
5205     trnlnm_iter_count = 0;
5206     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5207            && my_trnlnm(trndir,trndir,0)) {
5208       trnlnm_iter_count++;
5209       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5210       trnlen = strlen(trndir);
5211
5212       /* Trap simple rooted lnms, and return lnm:[000000] */
5213       if (!strcmp(trndir+trnlen-2,".]")) {
5214         if (buf) retpath = buf;
5215         else if (ts) Newx(retpath,strlen(dir)+10,char);
5216         else retpath = __pathify_retbuf;
5217         strcpy(retpath,dir);
5218         strcat(retpath,":[000000]");
5219         PerlMem_free(trndir);
5220         return retpath;
5221       }
5222     }
5223
5224     /* At this point we do not work with *dir, but the copy in
5225      * *trndir that is modifiable.
5226      */
5227
5228     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5229       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5230                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5231         retlen = 2 + (*(trndir+1) != '\0');
5232       else {
5233         if ( !(cp1 = strrchr(trndir,'/')) &&
5234              !(cp1 = strrchr(trndir,']')) &&
5235              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5236         if ((cp2 = strchr(cp1,'.')) != NULL &&
5237             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5238              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5239               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5240               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5241           int ver; char *cp3;
5242
5243           /* For EFS or ODS-5 look for the last dot */
5244           if (decc_efs_charset) {
5245             cp2 = strrchr(cp1,'.');
5246           }
5247           if (vms_process_case_tolerant) {
5248               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5249                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5250                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5251                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5252                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5253                             (ver || *cp3)))))) {
5254                 PerlMem_free(trndir);
5255                 set_errno(ENOTDIR);
5256                 set_vaxc_errno(RMS$_DIR);
5257                 return NULL;
5258               }
5259           }
5260           else {
5261               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5262                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5263                   !*(cp2+3) || *(cp2+3) != 'R' ||
5264                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5265                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5266                             (ver || *cp3)))))) {
5267                 PerlMem_free(trndir);
5268                 set_errno(ENOTDIR);
5269                 set_vaxc_errno(RMS$_DIR);
5270                 return NULL;
5271               }
5272           }
5273           retlen = cp2 - trndir + 1;
5274         }
5275         else {  /* No file type present.  Treat the filename as a directory. */
5276           retlen = strlen(trndir) + 1;
5277         }
5278       }
5279       if (buf) retpath = buf;
5280       else if (ts) Newx(retpath,retlen+1,char);
5281       else retpath = __pathify_retbuf;
5282       strncpy(retpath, trndir, retlen-1);
5283       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5284         retpath[retlen-1] = '/';      /* with '/', add it. */
5285         retpath[retlen] = '\0';
5286       }
5287       else retpath[retlen-1] = '\0';
5288     }
5289     else {  /* VMS-style directory spec */
5290       char *esa, *cp;
5291       unsigned long int sts, cmplen, haslower;
5292       struct FAB dirfab = cc$rms_fab;
5293       int dirlen;
5294       rms_setup_nam(savnam);
5295       rms_setup_nam(dirnam);
5296
5297       /* If we've got an explicit filename, we can just shuffle the string. */
5298       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5299              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5300         if ((cp2 = strchr(cp1,'.')) != NULL) {
5301           int ver; char *cp3;
5302           if (vms_process_case_tolerant) {
5303               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5304                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5305                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5306                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5307                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5308                             (ver || *cp3)))))) {
5309                PerlMem_free(trndir);
5310                set_errno(ENOTDIR);
5311                set_vaxc_errno(RMS$_DIR);
5312                return NULL;
5313              }
5314           }
5315           else {
5316               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5317                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5318                   !*(cp2+3) || *(cp2+3) != 'R' ||
5319                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5320                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5321                             (ver || *cp3)))))) {
5322                PerlMem_free(trndir);
5323                set_errno(ENOTDIR);
5324                set_vaxc_errno(RMS$_DIR);
5325                return NULL;
5326              }
5327           }
5328         }
5329         else {  /* No file type, so just draw name into directory part */
5330           for (cp2 = cp1; *cp2; cp2++) ;
5331         }
5332         *cp2 = *cp1;
5333         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5334         *cp1 = '.';
5335         /* We've now got a VMS 'path'; fall through */
5336       }
5337
5338       dirlen = strlen(trndir);
5339       if (trndir[dirlen-1] == ']' ||
5340           trndir[dirlen-1] == '>' ||
5341           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5342         if (buf) retpath = buf;
5343         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5344         else retpath = __pathify_retbuf;
5345         strcpy(retpath,trndir);
5346         PerlMem_free(trndir);
5347         return retpath;
5348       }
5349       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5350       esa = PerlMem_malloc(VMS_MAXRSS);
5351       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5352       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5353       rms_bind_fab_nam(dirfab, dirnam);
5354       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5355 #ifdef NAM$M_NO_SHORT_UPCASE
5356       if (decc_efs_case_preserve)
5357           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5358 #endif
5359
5360       for (cp = trndir; *cp; cp++)
5361         if (islower(*cp)) { haslower = 1; break; }
5362
5363       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5364         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5365           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5366           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5367         }
5368         if (!sts) {
5369           PerlMem_free(trndir);
5370           PerlMem_free(esa);
5371           set_errno(EVMSERR);
5372           set_vaxc_errno(dirfab.fab$l_sts);
5373           return NULL;
5374         }
5375       }
5376       else {
5377         savnam = dirnam;
5378         /* Does the file really exist? */
5379         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5380           if (dirfab.fab$l_sts != RMS$_FNF) {
5381             int sts1;
5382             sts1 = rms_free_search_context(&dirfab);
5383             PerlMem_free(trndir);
5384             PerlMem_free(esa);
5385             set_errno(EVMSERR);
5386             set_vaxc_errno(dirfab.fab$l_sts);
5387             return NULL;
5388           }
5389           dirnam = savnam; /* No; just work with potential name */
5390         }
5391       }
5392       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5393         /* Yep; check version while we're at it, if it's there. */
5394         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5395         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5396           int sts2;
5397           /* Something other than .DIR[;1].  Bzzt. */
5398           sts2 = rms_free_search_context(&dirfab);
5399           PerlMem_free(trndir);
5400           PerlMem_free(esa);
5401           set_errno(ENOTDIR);
5402           set_vaxc_errno(RMS$_DIR);
5403           return NULL;
5404         }
5405       }
5406       /* OK, the type was fine.  Now pull any file name into the
5407          directory path. */
5408       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5409       else {
5410         cp1 = strrchr(esa,'>');
5411         *(rms_nam_typel(dirnam)) = '>';
5412       }
5413       *cp1 = '.';
5414       *(rms_nam_typel(dirnam) + 1) = '\0';
5415       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5416       if (buf) retpath = buf;
5417       else if (ts) Newx(retpath,retlen,char);
5418       else retpath = __pathify_retbuf;
5419       strcpy(retpath,esa);
5420       PerlMem_free(esa);
5421       sts = rms_free_search_context(&dirfab);
5422       /* $PARSE may have upcased filespec, so convert output to lower
5423        * case if input contained any lowercase characters. */
5424       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5425     }
5426
5427     PerlMem_free(trndir);
5428     return retpath;
5429 }  /* end of do_pathify_dirspec() */
5430 /*}}}*/
5431 /* External entry points */
5432 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5433 { return do_pathify_dirspec(dir,buf,0); }
5434 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5435 { return do_pathify_dirspec(dir,buf,1); }
5436
5437 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5438 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5439 {
5440   static char __tounixspec_retbuf[VMS_MAXRSS];
5441   char *dirend, *rslt, *cp1, *cp3, *tmp;
5442   const char *cp2;
5443   int devlen, dirlen, retlen = VMS_MAXRSS;
5444   int expand = 1; /* guarantee room for leading and trailing slashes */
5445   unsigned short int trnlnm_iter_count;
5446   int cmp_rslt;
5447
5448   if (spec == NULL) return NULL;
5449   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5450   if (buf) rslt = buf;
5451   else if (ts) {
5452     Newx(rslt, VMS_MAXRSS, char);
5453   }
5454   else rslt = __tounixspec_retbuf;
5455
5456   /* New VMS specific format needs translation
5457    * glob passes filenames with trailing '\n' and expects this preserved.
5458    */
5459   if (decc_posix_compliant_pathnames) {
5460     if (strncmp(spec, "\"^UP^", 5) == 0) {
5461       char * uspec;
5462       char *tunix;
5463       int tunix_len;
5464       int nl_flag;
5465
5466       tunix = PerlMem_malloc(VMS_MAXRSS);
5467       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5468       strcpy(tunix, spec);
5469       tunix_len = strlen(tunix);
5470       nl_flag = 0;
5471       if (tunix[tunix_len - 1] == '\n') {
5472         tunix[tunix_len - 1] = '\"';
5473         tunix[tunix_len] = '\0';
5474         tunix_len--;
5475         nl_flag = 1;
5476       }
5477       uspec = decc$translate_vms(tunix);
5478       PerlMem_free(tunix);
5479       if ((int)uspec > 0) {
5480         strcpy(rslt,uspec);
5481         if (nl_flag) {
5482           strcat(rslt,"\n");
5483         }
5484         else {
5485           /* If we can not translate it, makemaker wants as-is */
5486           strcpy(rslt, spec);
5487         }
5488         return rslt;
5489       }
5490     }
5491   }
5492
5493   cmp_rslt = 0; /* Presume VMS */
5494   cp1 = strchr(spec, '/');
5495   if (cp1 == NULL)
5496     cmp_rslt = 0;
5497
5498     /* Look for EFS ^/ */
5499     if (decc_efs_charset) {
5500       while (cp1 != NULL) {
5501         cp2 = cp1 - 1;
5502         if (*cp2 != '^') {
5503           /* Found illegal VMS, assume UNIX */
5504           cmp_rslt = 1;
5505           break;
5506         }
5507       cp1++;
5508       cp1 = strchr(cp1, '/');
5509     }
5510   }
5511
5512   /* Look for "." and ".." */
5513   if (decc_filename_unix_report) {
5514     if (spec[0] == '.') {
5515       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5516         cmp_rslt = 1;
5517       }
5518       else {
5519         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5520           cmp_rslt = 1;
5521         }
5522       }
5523     }
5524   }
5525   /* This is already UNIX or at least nothing VMS understands */
5526   if (cmp_rslt) {
5527     strcpy(rslt,spec);
5528     return rslt;
5529   }
5530
5531   cp1 = rslt;
5532   cp2 = spec;
5533   dirend = strrchr(spec,']');
5534   if (dirend == NULL) dirend = strrchr(spec,'>');
5535   if (dirend == NULL) dirend = strchr(spec,':');
5536   if (dirend == NULL) {
5537     strcpy(rslt,spec);
5538     return rslt;
5539   }
5540
5541   /* Special case 1 - sys$posix_root = / */
5542 #if __CRTL_VER >= 70000000
5543   if (!decc_disable_posix_root) {
5544     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5545       *cp1 = '/';
5546       cp1++;
5547       cp2 = cp2 + 15;
5548       }
5549   }
5550 #endif
5551
5552   /* Special case 2 - Convert NLA0: to /dev/null */
5553 #if __CRTL_VER < 70000000
5554   cmp_rslt = strncmp(spec,"NLA0:", 5);
5555   if (cmp_rslt != 0)
5556      cmp_rslt = strncmp(spec,"nla0:", 5);
5557 #else
5558   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5559 #endif
5560   if (cmp_rslt == 0) {
5561     strcpy(rslt, "/dev/null");
5562     cp1 = cp1 + 9;
5563     cp2 = cp2 + 5;
5564     if (spec[6] != '\0') {
5565       cp1[9] == '/';
5566       cp1++;
5567       cp2++;
5568     }
5569   }
5570
5571    /* Also handle special case "SYS$SCRATCH:" */
5572 #if __CRTL_VER < 70000000
5573   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5574   if (cmp_rslt != 0)
5575      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5576 #else
5577   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5578 #endif
5579   tmp = PerlMem_malloc(VMS_MAXRSS);
5580   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5581   if (cmp_rslt == 0) {
5582   int islnm;
5583
5584     islnm = my_trnlnm(tmp, "TMP", 0);
5585     if (!islnm) {
5586       strcpy(rslt, "/tmp");
5587       cp1 = cp1 + 4;
5588       cp2 = cp2 + 12;
5589       if (spec[12] != '\0') {
5590         cp1[4] == '/';
5591         cp1++;
5592         cp2++;
5593       }
5594     }
5595   }
5596
5597   if (*cp2 != '[' && *cp2 != '<') {
5598     *(cp1++) = '/';
5599   }
5600   else {  /* the VMS spec begins with directories */
5601     cp2++;
5602     if (*cp2 == ']' || *cp2 == '>') {
5603       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5604       PerlMem_free(tmp);
5605       return rslt;
5606     }
5607     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5608       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5609         if (ts) Safefree(rslt);
5610         PerlMem_free(tmp);
5611         return NULL;
5612       }
5613       trnlnm_iter_count = 0;
5614       do {
5615         cp3 = tmp;
5616         while (*cp3 != ':' && *cp3) cp3++;
5617         *(cp3++) = '\0';
5618         if (strchr(cp3,']') != NULL) break;
5619         trnlnm_iter_count++;
5620         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5621       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5622       if (ts && !buf &&
5623           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5624         retlen = devlen + dirlen;
5625         Renew(rslt,retlen+1+2*expand,char);
5626         cp1 = rslt;
5627       }
5628       cp3 = tmp;
5629       *(cp1++) = '/';
5630       while (*cp3) {
5631         *(cp1++) = *(cp3++);
5632         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5633             PerlMem_free(tmp);
5634             return NULL; /* No room */
5635         }
5636       }
5637       *(cp1++) = '/';
5638     }
5639     if ((*cp2 == '^')) {
5640         /* EFS file escape, pass the next character as is */
5641         /* Fix me: HEX encoding for UNICODE not implemented */
5642         cp2++;
5643     }
5644     else if ( *cp2 == '.') {
5645       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5646         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5647         cp2 += 3;
5648       }
5649       else cp2++;
5650     }
5651   }
5652   PerlMem_free(tmp);
5653   for (; cp2 <= dirend; cp2++) {
5654     if ((*cp2 == '^')) {
5655         /* EFS file escape, pass the next character as is */
5656         /* Fix me: HEX encoding for UNICODE not implemented */
5657         cp2++;
5658         *(cp1++) = *cp2;
5659     }
5660     if (*cp2 == ':') {
5661       *(cp1++) = '/';
5662       if (*(cp2+1) == '[') cp2++;
5663     }
5664     else if (*cp2 == ']' || *cp2 == '>') {
5665       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5666     }
5667     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5668       *(cp1++) = '/';
5669       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5670         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5671                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5672         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5673             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5674       }
5675       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5676         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5677         cp2 += 2;
5678       }
5679     }
5680     else if (*cp2 == '-') {
5681       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5682         while (*cp2 == '-') {
5683           cp2++;
5684           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5685         }
5686         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5687           if (ts) Safefree(rslt);                        /* filespecs like */
5688           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5689           return NULL;
5690         }
5691       }
5692       else *(cp1++) = *cp2;
5693     }
5694     else *(cp1++) = *cp2;
5695   }
5696   while (*cp2) *(cp1++) = *(cp2++);
5697   *cp1 = '\0';
5698
5699   /* This still leaves /000000/ when working with a
5700    * VMS device root or concealed root.
5701    */
5702   {
5703   int ulen;
5704   char * zeros;
5705
5706       ulen = strlen(rslt);
5707
5708       /* Get rid of "000000/ in rooted filespecs */
5709       if (ulen > 7) {
5710         zeros = strstr(rslt, "/000000/");
5711         if (zeros != NULL) {
5712           int mlen;
5713           mlen = ulen - (zeros - rslt) - 7;
5714           memmove(zeros, &zeros[7], mlen);
5715           ulen = ulen - 7;
5716           rslt[ulen] = '\0';
5717         }
5718       }
5719   }
5720
5721   return rslt;
5722
5723 }  /* end of do_tounixspec() */
5724 /*}}}*/
5725 /* External entry points */
5726 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5727 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5728
5729 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5730
5731 static int posix_to_vmsspec
5732   (char *vmspath, int vmspath_len, const char *unixpath) {
5733 int sts;
5734 struct FAB myfab = cc$rms_fab;
5735 struct NAML mynam = cc$rms_naml;
5736 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5737  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5738 char *esa;
5739 char *vms_delim;
5740 int dir_flag;
5741 int unixlen;
5742
5743   /* If not a posix spec already, convert it */
5744   dir_flag = 0;
5745   unixlen = strlen(unixpath);
5746   if (unixlen == 0) {
5747     vmspath[0] = '\0';
5748     return SS$_NORMAL;
5749   }
5750   if (strncmp(unixpath,"\"^UP^",5) != 0) {
5751     sprintf(vmspath,"\"^UP^%s\"",unixpath);
5752   }
5753   else {
5754     /* This is already a VMS specification, no conversion */
5755     unixlen--;
5756     strncpy(vmspath,unixpath, vmspath_len);
5757   }
5758   vmspath[vmspath_len] = 0;
5759   if (unixpath[unixlen - 1] == '/')
5760   dir_flag = 1;
5761   esa = PerlMem_malloc(VMS_MAXRSS);
5762   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5763   myfab.fab$l_fna = vmspath;
5764   myfab.fab$b_fns = strlen(vmspath);
5765   myfab.fab$l_naml = &mynam;
5766   mynam.naml$l_esa = NULL;
5767   mynam.naml$b_ess = 0;
5768   mynam.naml$l_long_expand = esa;
5769   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5770   mynam.naml$l_rsa = NULL;
5771   mynam.naml$b_rss = 0;
5772   if (decc_efs_case_preserve)
5773     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5774   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5775
5776   /* Set up the remaining naml fields */
5777   sts = sys$parse(&myfab);
5778
5779   /* It failed! Try again as a UNIX filespec */
5780   if (!(sts & 1)) {
5781     PerlMem_free(esa);
5782     return sts;
5783   }
5784
5785    /* get the Device ID and the FID */
5786    sts = sys$search(&myfab);
5787    /* on any failure, returned the POSIX ^UP^ filespec */
5788    if (!(sts & 1)) {
5789       PerlMem_free(esa);
5790       return sts;
5791    }
5792    specdsc.dsc$a_pointer = vmspath;
5793    specdsc.dsc$w_length = vmspath_len;
5794
5795    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5796    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5797    sts = lib$fid_to_name
5798       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5799
5800   /* on any failure, returned the POSIX ^UP^ filespec */
5801   if (!(sts & 1)) {
5802      /* This can happen if user does not have permission to read directories */
5803      if (strncmp(unixpath,"\"^UP^",5) != 0)
5804        sprintf(vmspath,"\"^UP^%s\"",unixpath);
5805      else
5806        strcpy(vmspath, unixpath);
5807   }
5808   else {
5809     vmspath[specdsc.dsc$w_length] = 0;
5810
5811     /* Are we expecting a directory? */
5812     if (dir_flag != 0) {
5813     int i;
5814     char *eptr;
5815
5816       eptr = NULL;
5817
5818       i = specdsc.dsc$w_length - 1;
5819       while (i > 0) {
5820       int zercnt;
5821         zercnt = 0;
5822         /* Version must be '1' */
5823         if (vmspath[i--] != '1')
5824           break;
5825         /* Version delimiter is one of ".;" */
5826         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5827           break;
5828         i--;
5829         if (vmspath[i--] != 'R')
5830           break;
5831         if (vmspath[i--] != 'I')
5832           break;
5833         if (vmspath[i--] != 'D')
5834           break;
5835         if (vmspath[i--] != '.')
5836           break;
5837         eptr = &vmspath[i+1];
5838         while (i > 0) {
5839           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5840             if (vmspath[i-1] != '^') {
5841               if (zercnt != 6) {
5842                 *eptr = vmspath[i];
5843                 eptr[1] = '\0';
5844                 vmspath[i] = '.';
5845                 break;
5846               }
5847               else {
5848                 /* Get rid of 6 imaginary zero directory filename */
5849                 vmspath[i+1] = '\0';
5850               }
5851             }
5852           }
5853           if (vmspath[i] == '0')
5854             zercnt++;
5855           else
5856             zercnt = 10;
5857           i--;
5858         }
5859         break;
5860       }
5861     }
5862   }
5863   PerlMem_free(esa);
5864   return sts;
5865 }
5866
5867 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5868 static int posix_to_vmsspec_hardway
5869   (char *vmspath, int vmspath_len, const char *unixpath) {
5870
5871 char *esa;
5872 const char *unixptr;
5873 char *vmsptr;
5874 const char *lastslash;
5875 const char *lastdot;
5876 int unixlen;
5877 int vmslen;
5878 int dir_start;
5879 int dir_dot;
5880 int quoted;
5881
5882
5883   unixptr = unixpath;
5884   dir_dot = 0;
5885
5886   /* Ignore leading "/" characters */
5887   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5888     unixptr++;
5889   }
5890   unixlen = strlen(unixptr);
5891
5892   /* Do nothing with blank paths */
5893   if (unixlen == 0) {
5894     vmspath[0] = '\0';
5895     return SS$_NORMAL;
5896   }
5897
5898   lastslash = strrchr(unixptr,'/');
5899   lastdot = strrchr(unixptr,'.');
5900
5901
5902   /* last dot is last dot or past end of string */
5903   if (lastdot == NULL)
5904     lastdot = unixptr + unixlen;
5905
5906   /* if no directories, set last slash to beginning of string */
5907   if (lastslash == NULL) {
5908     lastslash = unixptr;
5909   }
5910   else {
5911     /* Watch out for trailing "." after last slash, still a directory */
5912     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5913       lastslash = unixptr + unixlen;
5914     }
5915
5916     /* Watch out for traiing ".." after last slash, still a directory */
5917     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5918       lastslash = unixptr + unixlen;
5919     }
5920
5921     /* dots in directories are aways escaped */
5922     if (lastdot < lastslash)
5923       lastdot = unixptr + unixlen;
5924   }
5925
5926   /* if (unixptr < lastslash) then we are in a directory */
5927
5928   dir_start = 0;
5929   quoted = 0;
5930
5931   vmsptr = vmspath;
5932   vmslen = 0;
5933
5934   /* This could have a "^UP^ on the front */
5935   if (strncmp(unixptr,"\"^UP^",5) == 0) {
5936     quoted = 1;
5937     unixptr+= 5;
5938   }
5939
5940   /* Start with the UNIX path */
5941   if (*unixptr != '/') {
5942     /* relative paths */
5943     if (lastslash > unixptr) {
5944     int dotdir_seen;
5945
5946       /* skip leading ./ */
5947       dotdir_seen = 0;
5948       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5949         dotdir_seen = 1;
5950         unixptr++;
5951         unixptr++;
5952       }
5953
5954       /* Are we still in a directory? */
5955       if (unixptr <= lastslash) {
5956         *vmsptr++ = '[';
5957         vmslen = 1;
5958         dir_start = 1;
5959
5960         /* if not backing up, then it is relative forward. */
5961         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5962               ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5963           *vmsptr++ = '.';
5964           vmslen++;
5965           dir_dot = 1;
5966         }
5967        }
5968        else {
5969          if (dotdir_seen) {
5970            /* Perl wants an empty directory here to tell the difference
5971             * between a DCL commmand and a filename
5972             */
5973           *vmsptr++ = '[';
5974           *vmsptr++ = ']';
5975           vmslen = 2;
5976         }
5977       }
5978     }
5979     else {
5980       /* Handle two special files . and .. */
5981       if (unixptr[0] == '.') {
5982         if (unixptr[1] == '\0') {
5983           *vmsptr++ = '[';
5984           *vmsptr++ = ']';
5985           vmslen += 2;
5986           *vmsptr++ = '\0';
5987           return SS$_NORMAL;
5988         }
5989         if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5990           *vmsptr++ = '[';
5991           *vmsptr++ = '-';
5992           *vmsptr++ = ']';
5993           vmslen += 3;
5994           *vmsptr++ = '\0';
5995           return SS$_NORMAL;
5996         }
5997       }
5998     }
5999   }
6000   else {        /* Absolute PATH handling */
6001   int sts;
6002   char * nextslash;
6003   int seg_len;
6004     /* Need to find out where root is */
6005
6006     /* In theory, this procedure should never get an absolute POSIX pathname
6007      * that can not be found on the POSIX root.
6008      * In practice, that can not be relied on, and things will show up
6009      * here that are a VMS device name or concealed logical name instead.
6010      * So to make things work, this procedure must be tolerant.
6011      */
6012     esa = PerlMem_malloc(vmspath_len);
6013     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6014
6015     sts = SS$_NORMAL;
6016     nextslash = strchr(&unixptr[1],'/');
6017     seg_len = 0;
6018     if (nextslash != NULL) {
6019       seg_len = nextslash - &unixptr[1];
6020       strncpy(vmspath, unixptr, seg_len + 1);
6021       vmspath[seg_len+1] = 0;
6022       sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
6023     }
6024
6025     if (sts & 1) {
6026       /* This is verified to be a real path */
6027
6028       sts = posix_to_vmsspec(esa, vmspath_len, "/");
6029       strcpy(vmspath, esa);
6030       vmslen = strlen(vmspath);
6031       vmsptr = vmspath + vmslen;
6032       unixptr++;
6033       if (unixptr < lastslash) {
6034       char * rptr;
6035         vmsptr--;
6036         *vmsptr++ = '.';
6037         dir_start = 1;
6038         dir_dot = 1;
6039         if (vmslen > 7) {
6040         int cmp;
6041           rptr = vmsptr - 7;
6042           cmp = strcmp(rptr,"000000.");
6043           if (cmp == 0) {
6044             vmslen -= 7;
6045             vmsptr -= 7;
6046             vmsptr[1] = '\0';
6047           } /* removing 6 zeros */
6048         } /* vmslen < 7, no 6 zeros possible */
6049       } /* Not in a directory */
6050     } /* end of verified real path handling */
6051     else {
6052     int add_6zero;
6053     int islnm;
6054
6055       /* Ok, we have a device or a concealed root that is not in POSIX
6056        * or we have garbage.  Make the best of it.
6057        */
6058
6059       /* Posix to VMS destroyed this, so copy it again */
6060       strncpy(vmspath, &unixptr[1], seg_len);
6061       vmspath[seg_len] = 0;
6062       vmslen = seg_len;
6063       vmsptr = &vmsptr[vmslen];
6064       islnm = 0;
6065
6066       /* Now do we need to add the fake 6 zero directory to it? */
6067       add_6zero = 1;
6068       if ((*lastslash == '/') && (nextslash < lastslash)) {
6069         /* No there is another directory */
6070         add_6zero = 0;
6071       }
6072       else {
6073       int trnend;
6074
6075         /* now we have foo:bar or foo:[000000]bar to decide from */
6076         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6077         trnend = islnm ? islnm - 1 : 0;
6078
6079         /* if this was a logical name, ']' or '>' must be present */
6080         /* if not a logical name, then assume a device and hope. */
6081         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6082
6083         /* if log name and trailing '.' then rooted - treat as device */
6084         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6085
6086         /* Fix me, if not a logical name, a device lookup should be
6087          * done to see if the device is file structured.  If the device
6088          * is not file structured, the 6 zeros should not be put on.
6089          *
6090          * As it is, perl is occasionally looking for dev:[000000]tty.
6091          * which looks a little strange.
6092          */
6093
6094         if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
6095           /* No real directory present */
6096           add_6zero = 1;
6097         }
6098       }
6099
6100       /* Put the device delimiter on */
6101       *vmsptr++ = ':';
6102       vmslen++;
6103       unixptr = nextslash;
6104       unixptr++;
6105
6106       /* Start directory if needed */
6107       if (!islnm || add_6zero) {
6108         *vmsptr++ = '[';
6109         vmslen++;
6110         dir_start = 1;
6111       }
6112
6113       /* add fake 000000] if needed */
6114       if (add_6zero) {
6115         *vmsptr++ = '0';
6116         *vmsptr++ = '0';
6117         *vmsptr++ = '0';
6118         *vmsptr++ = '0';
6119         *vmsptr++ = '0';
6120         *vmsptr++ = '0';
6121         *vmsptr++ = ']';
6122         vmslen += 7;
6123         dir_start = 0;
6124       }
6125
6126     } /* non-POSIX translation */
6127     PerlMem_free(esa);
6128   } /* End of relative/absolute path handling */
6129
6130   while ((*unixptr) && (vmslen < vmspath_len)){
6131   int dash_flag;
6132
6133     dash_flag = 0;
6134
6135     if (dir_start != 0) {
6136
6137       /* First characters in a directory are handled special */
6138       while ((*unixptr == '/') ||
6139              ((*unixptr == '.') &&
6140               ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
6141       int loop_flag;
6142
6143         loop_flag = 0;
6144
6145         /* Skip redundant / in specification */
6146         while ((*unixptr == '/') && (dir_start != 0)) {
6147           loop_flag = 1;
6148           unixptr++;
6149           if (unixptr == lastslash)
6150             break;
6151         }
6152         if (unixptr == lastslash)
6153           break;
6154
6155         /* Skip redundant ./ characters */
6156         while ((*unixptr == '.') &&
6157                ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
6158           loop_flag = 1;
6159           unixptr++;
6160           if (unixptr == lastslash)
6161             break;
6162           if (*unixptr == '/')
6163             unixptr++;
6164         }
6165         if (unixptr == lastslash)
6166           break;
6167
6168         /* Skip redundant ../ characters */
6169         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6170              ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
6171           /* Set the backing up flag */
6172           loop_flag = 1;
6173           dir_dot = 0;
6174           dash_flag = 1;
6175           *vmsptr++ = '-';
6176           vmslen++;
6177           unixptr++; /* first . */
6178           unixptr++; /* second . */
6179           if (unixptr == lastslash)
6180             break;
6181           if (*unixptr == '/') /* The slash */
6182             unixptr++;
6183         }
6184         if (unixptr == lastslash)
6185           break;
6186
6187         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6188         /* Not needed when VMS is pretending to be UNIX. */
6189
6190         /* Is this loop stuck because of too many dots? */
6191         if (loop_flag == 0) {
6192           /* Exit the loop and pass the rest through */
6193           break;
6194         }
6195       }
6196
6197       /* Are we done with directories yet? */
6198       if (unixptr >= lastslash) {
6199
6200         /* Watch out for trailing dots */
6201         if (dir_dot != 0) {
6202             vmslen --;
6203             vmsptr--;
6204         }
6205         *vmsptr++ = ']';
6206         vmslen++;
6207         dash_flag = 0;
6208         dir_start = 0;
6209         if (*unixptr == '/')
6210           unixptr++;
6211       }
6212       else {
6213         /* Have we stopped backing up? */
6214         if (dash_flag) {
6215           *vmsptr++ = '.';
6216           vmslen++;
6217           dash_flag = 0;
6218           /* dir_start continues to be = 1 */
6219         }
6220         if (*unixptr == '-') {
6221           *vmsptr++ = '^';
6222           *vmsptr++ = *unixptr++;
6223           vmslen += 2;
6224           dir_start = 0;
6225
6226           /* Now are we done with directories yet? */
6227           if (unixptr >= lastslash) {
6228
6229             /* Watch out for trailing dots */
6230             if (dir_dot != 0) {
6231               vmslen --;
6232               vmsptr--;
6233             }
6234
6235             *vmsptr++ = ']';
6236             vmslen++;
6237             dash_flag = 0;
6238             dir_start = 0;
6239           }
6240         }
6241       }
6242     }
6243
6244     /* All done? */
6245     if (*unixptr == '\0')
6246       break;
6247
6248     /* Normal characters - More EFS work probably needed */
6249     dir_start = 0;
6250     dir_dot = 0;
6251
6252     switch(*unixptr) {
6253     case '/':
6254         /* remove multiple / */
6255         while (unixptr[1] == '/') {
6256            unixptr++;
6257         }
6258         if (unixptr == lastslash) {
6259           /* Watch out for trailing dots */
6260           if (dir_dot != 0) {
6261             vmslen --;
6262             vmsptr--;
6263           }
6264           *vmsptr++ = ']';
6265         }
6266         else {
6267           dir_start = 1;
6268           *vmsptr++ = '.';
6269           dir_dot = 1;
6270
6271           /* To do: Perl expects /.../ to be translated to [...] on VMS */
6272           /* Not needed when VMS is pretending to be UNIX. */
6273
6274         }
6275         dash_flag = 0;
6276         if (*unixptr != '\0')
6277           unixptr++;
6278         vmslen++;
6279         break;
6280     case '?':
6281         *vmsptr++ = '%';
6282         vmslen++;
6283         unixptr++;
6284         break;
6285     case ' ':
6286         *vmsptr++ = '^';
6287         *vmsptr++ = '_';
6288         vmslen += 2;
6289         unixptr++;
6290         break;
6291     case '.':
6292         if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
6293           *vmsptr++ = '^';
6294           *vmsptr++ = '.';
6295           vmslen += 2;
6296           unixptr++;
6297
6298           /* trailing dot ==> '^..' on VMS */
6299           if (*unixptr == '\0') {
6300             *vmsptr++ = '.';
6301             vmslen++;
6302           }
6303           *vmsptr++ = *unixptr++;
6304           vmslen ++;
6305         }
6306         if (quoted && (unixptr[1] == '\0')) {
6307           unixptr++;
6308           break;
6309         }
6310         *vmsptr++ = '^';
6311         *vmsptr++ = *unixptr++;
6312         vmslen += 2;
6313         break;
6314     case '~':
6315     case ';':
6316     case '\\':
6317         *vmsptr++ = '^';
6318         *vmsptr++ = *unixptr++;
6319         vmslen += 2;
6320         break;
6321     default:
6322         if (*unixptr != '\0') {
6323           *vmsptr++ = *unixptr++;
6324           vmslen++;
6325         }
6326         break;
6327     }
6328   }
6329
6330   /* Make sure directory is closed */
6331   if (unixptr == lastslash) {
6332     char *vmsptr2;
6333     vmsptr2 = vmsptr - 1;
6334
6335     if (*vmsptr2 != ']') {
6336       *vmsptr2--;
6337
6338       /* directories do not end in a dot bracket */
6339       if (*vmsptr2 == '.') {
6340         vmsptr2--;
6341
6342         /* ^. is allowed */
6343         if (*vmsptr2 != '^') {
6344           vmsptr--; /* back up over the dot */
6345         }
6346       }
6347       *vmsptr++ = ']';
6348     }
6349   }
6350   else {
6351     char *vmsptr2;
6352     /* Add a trailing dot if a file with no extension */
6353     vmsptr2 = vmsptr - 1;
6354     if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6355         (*lastdot != '.')) {
6356         *vmsptr++ = '.';
6357         vmslen++;
6358     }
6359   }
6360
6361   *vmsptr = '\0';
6362   return SS$_NORMAL;
6363 }
6364 #endif
6365
6366 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6367 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6368   static char __tovmsspec_retbuf[VMS_MAXRSS];
6369   char *rslt, *dirend;
6370   char *lastdot;
6371   char *vms_delim;
6372   register char *cp1;
6373   const char *cp2;
6374   unsigned long int infront = 0, hasdir = 1;
6375   int rslt_len;
6376   int no_type_seen;
6377
6378   if (path == NULL) return NULL;
6379   rslt_len = VMS_MAXRSS-1;
6380   if (buf) rslt = buf;
6381   else if (ts) Newx(rslt, VMS_MAXRSS, char);
6382   else rslt = __tovmsspec_retbuf;
6383   if (strpbrk(path,"]:>") ||
6384       (dirend = strrchr(path,'/')) == NULL) {
6385     if (path[0] == '.') {
6386       if (path[1] == '\0') strcpy(rslt,"[]");
6387       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6388       else strcpy(rslt,path); /* probably garbage */
6389     }
6390     else strcpy(rslt,path);
6391     return rslt;
6392   }
6393
6394    /* Posix specifications are now a native VMS format */
6395   /*--------------------------------------------------*/
6396 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6397   if (decc_posix_compliant_pathnames) {
6398     if (strncmp(path,"\"^UP^",5) == 0) {
6399       posix_to_vmsspec_hardway(rslt, rslt_len, path);
6400       return rslt;
6401     }
6402   }
6403 #endif
6404
6405   vms_delim = strpbrk(path,"]:>");
6406
6407   if ((vms_delim != NULL) ||
6408       ((dirend = strrchr(path,'/')) == NULL)) {
6409
6410     /* VMS special characters found! */
6411
6412     if (path[0] == '.') {
6413       if (path[1] == '\0') strcpy(rslt,"[]");
6414       else if (path[1] == '.' && path[2] == '\0')
6415         strcpy(rslt,"[-]");
6416
6417       /* Dot preceeding a device or directory ? */
6418       else {
6419         /* If not in POSIX mode, pass it through and hope it works */
6420 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6421         if (!decc_posix_compliant_pathnames)
6422           strcpy(rslt,path); /* probably garbage */
6423         else
6424           posix_to_vmsspec_hardway(rslt, rslt_len, path);
6425 #else
6426         strcpy(rslt,path); /* probably garbage */
6427 #endif
6428       }
6429     }
6430     else {
6431
6432        /* If no VMS characters and in POSIX mode, convert it!
6433         * This is the easiest way to get directory specifications
6434         * handled correctly in POSIX mode
6435         */
6436 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6437       if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6438         posix_to_vmsspec_hardway(rslt, rslt_len, path);
6439       else {
6440         /* No unix path separators - presume VMS already */
6441         strcpy(rslt,path);
6442       }
6443 #else
6444       strcpy(rslt,path); /* probably garbage */
6445 #endif
6446     }
6447     return rslt;
6448   }
6449
6450 /* If POSIX mode active, handle the conversion */
6451 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6452   if (decc_posix_compliant_pathnames) {
6453     posix_to_vmsspec_hardway(rslt, rslt_len, path);
6454     return rslt;
6455   }
6456 #endif
6457
6458   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
6459     if (!*(dirend+2)) dirend +=2;
6460     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6461     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6462   }
6463
6464   cp1 = rslt;
6465   cp2 = path;
6466   lastdot = strrchr(cp2,'.');
6467   if (*cp2 == '/') {
6468     char *trndev;
6469     int islnm, rooted;
6470     STRLEN trnend;
6471
6472     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6473     if (!*(cp2+1)) {
6474       if (decc_disable_posix_root) {
6475         strcpy(rslt,"sys$disk:[000000]");
6476       }
6477       else {
6478         strcpy(rslt,"sys$posix_root:[000000]");
6479       }
6480       return rslt;
6481     }
6482     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6483     *cp1 = '\0';
6484     trndev = PerlMem_malloc(VMS_MAXRSS);
6485     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
6486     islnm =  my_trnlnm(rslt,trndev,0);
6487
6488      /* DECC special handling */
6489     if (!islnm) {
6490       if (strcmp(rslt,"bin") == 0) {
6491         strcpy(rslt,"sys$system");
6492         cp1 = rslt + 10;
6493         *cp1 = 0;
6494         islnm =  my_trnlnm(rslt,trndev,0);
6495       }
6496       else if (strcmp(rslt,"tmp") == 0) {
6497         strcpy(rslt,"sys$scratch");
6498         cp1 = rslt + 11;
6499         *cp1 = 0;
6500         islnm =  my_trnlnm(rslt,trndev,0);
6501       }
6502       else if (!decc_disable_posix_root) {
6503         strcpy(rslt, "sys$posix_root");
6504         cp1 = rslt + 13;
6505         *cp1 = 0;
6506         cp2 = path;
6507         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6508         islnm =  my_trnlnm(rslt,trndev,0);
6509       }
6510       else if (strcmp(rslt,"dev") == 0) {
6511         if (strncmp(cp2,"/null", 5) == 0) {
6512           if ((cp2[5] == 0) || (cp2[5] == '/')) {
6513             strcpy(rslt,"NLA0");
6514             cp1 = rslt + 4;
6515             *cp1 = 0;
6516             cp2 = cp2 + 5;
6517             islnm =  my_trnlnm(rslt,trndev,0);
6518           }
6519         }
6520       }
6521     }
6522
6523     trnend = islnm ? strlen(trndev) - 1 : 0;
6524     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6525     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6526     /* If the first element of the path is a logical name, determine
6527      * whether it has to be translated so we can add more directories. */
6528     if (!islnm || rooted) {
6529       *(cp1++) = ':';
6530       *(cp1++) = '[';
6531       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6532       else cp2++;
6533     }
6534     else {
6535       if (cp2 != dirend) {
6536         strcpy(rslt,trndev);
6537         cp1 = rslt + trnend;
6538         if (*cp2 != 0) {
6539           *(cp1++) = '.';
6540           cp2++;
6541         }
6542       }
6543       else {
6544         if (decc_disable_posix_root) {
6545           *(cp1++) = ':';
6546           hasdir = 0;
6547         }
6548       }
6549     }
6550     PerlMem_free(trndev);
6551   }
6552   else {
6553     *(cp1++) = '[';
6554     if (*cp2 == '.') {
6555       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6556         cp2 += 2;         /* skip over "./" - it's redundant */
6557         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
6558       }
6559       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6560         *(cp1++) = '-';                                 /* "../" --> "-" */
6561         cp2 += 3;
6562       }
6563       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6564                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6565         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6566         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6567         cp2 += 4;
6568       }
6569       else if ((cp2 != lastdot) || (lastdot < dirend)) {
6570         /* Escape the extra dots in EFS file specifications */
6571         *(cp1++) = '^';
6572       }
6573       if (cp2 > dirend) cp2 = dirend;
6574     }
6575     else *(cp1++) = '.';
6576   }
6577   for (; cp2 < dirend; cp2++) {
6578     if (*cp2 == '/') {
6579       if (*(cp2-1) == '/') continue;
6580       if (*(cp1-1) != '.') *(cp1++) = '.';
6581       infront = 0;
6582     }
6583     else if (!infront && *cp2 == '.') {
6584       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6585       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
6586       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6587         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6588         else if (*(cp1-2) == '[') *(cp1-1) = '-';
6589         else {  /* back up over previous directory name */
6590           cp1--;
6591           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6592           if (*(cp1-1) == '[') {
6593             memcpy(cp1,"000000.",7);
6594             cp1 += 7;
6595           }
6596         }
6597         cp2 += 2;
6598         if (cp2 == dirend) break;
6599       }
6600       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6601                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6602         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6603         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6604         if (!*(cp2+3)) {
6605           *(cp1++) = '.';  /* Simulate trailing '/' */
6606           cp2 += 2;  /* for loop will incr this to == dirend */
6607         }
6608         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
6609       }
6610       else {
6611         if (decc_efs_charset == 0)
6612           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
6613         else {
6614           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
6615           *(cp1++) = '.';
6616         }
6617       }
6618     }
6619     else {
6620       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
6621       if (*cp2 == '.') {
6622         if (decc_efs_charset == 0)
6623           *(cp1++) = '_';
6624         else {
6625           *(cp1++) = '^';
6626           *(cp1++) = '.';
6627         }
6628       }
6629       else                  *(cp1++) =  *cp2;
6630       infront = 1;
6631     }
6632   }
6633   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6634   if (hasdir) *(cp1++) = ']';
6635   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
6636   /* fixme for ODS5 */
6637   no_type_seen = 0;
6638   if (cp2 > lastdot)
6639     no_type_seen = 1;
6640   while (*cp2) {
6641     switch(*cp2) {
6642     case '?':
6643         *(cp1++) = '%';
6644         cp2++;
6645     case ' ':
6646         *(cp1)++ = '^';
6647         *(cp1)++ = '_';
6648         cp2++;
6649         break;
6650     case '.':
6651         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6652             decc_readdir_dropdotnotype) {
6653           *(cp1)++ = '^';
6654           *(cp1)++ = '.';
6655           cp2++;
6656
6657           /* trailing dot ==> '^..' on VMS */
6658           if (*cp2 == '\0') {
6659             *(cp1++) = '.';
6660             no_type_seen = 0;
6661           }
6662         }
6663         else {
6664           *(cp1++) = *(cp2++);
6665           no_type_seen = 0;
6666         }
6667         break;
6668     case '\"':
6669     case '~':
6670     case '`':
6671     case '!':
6672     case '#':
6673     case '%':
6674     case '^':
6675     case '&':
6676     case '(':
6677     case ')':
6678     case '=':
6679     case '+':
6680     case '\'':
6681     case '@':
6682     case '[':
6683     case ']':
6684     case '{':
6685     case '}':
6686     case ':':
6687     case '\\':
6688     case '|':
6689     case '<':
6690     case '>':
6691         *(cp1++) = '^';
6692         *(cp1++) = *(cp2++);
6693         break;
6694     case ';':
6695         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6696          * which is wrong.  UNIX notation should be ".dir." unless
6697          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6698          * changing this behavior could break more things at this time.
6699          * efs character set effectively does not allow "." to be a version
6700          * delimiter as a further complication about changing this.
6701          */
6702         if (decc_filename_unix_report != 0) {
6703           *(cp1++) = '^';
6704         }
6705         *(cp1++) = *(cp2++);
6706         break;
6707     default:
6708         *(cp1++) = *(cp2++);
6709     }
6710   }
6711   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6712   char *lcp1;
6713     lcp1 = cp1;
6714     lcp1--;
6715      /* Fix me for "^]", but that requires making sure that you do
6716       * not back up past the start of the filename
6717       */
6718     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6719       *cp1++ = '.';
6720   }
6721   *cp1 = '\0';
6722
6723   return rslt;
6724
6725 }  /* end of do_tovmsspec() */
6726 /*}}}*/
6727 /* External entry points */
6728 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6729 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6730
6731 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6732 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6733   static char __tovmspath_retbuf[VMS_MAXRSS];
6734   int vmslen;
6735   char *pathified, *vmsified, *cp;
6736
6737   if (path == NULL) return NULL;
6738   pathified = PerlMem_malloc(VMS_MAXRSS);
6739   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
6740   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6741     PerlMem_free(pathified);
6742     return NULL;
6743   }
6744
6745   vmsified = NULL;
6746   if (buf == NULL)
6747      Newx(vmsified, VMS_MAXRSS, char);
6748   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0) == NULL) {
6749     PerlMem_free(pathified);
6750     if (vmsified) Safefree(vmsified);
6751     return NULL;
6752   }
6753   PerlMem_free(pathified);
6754   if (buf) {
6755     return buf;
6756   }
6757   else if (ts) {
6758     vmslen = strlen(vmsified);
6759     Newx(cp,vmslen+1,char);
6760     memcpy(cp,vmsified,vmslen);
6761     cp[vmslen] = '\0';
6762     Safefree(vmsified);
6763     return cp;
6764   }
6765   else {
6766     strcpy(__tovmspath_retbuf,vmsified);
6767     Safefree(vmsified);
6768     return __tovmspath_retbuf;
6769   }
6770
6771 }  /* end of do_tovmspath() */
6772 /*}}}*/
6773 /* External entry points */
6774 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6775 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6776
6777
6778 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6779 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6780   static char __tounixpath_retbuf[VMS_MAXRSS];
6781   int unixlen;
6782   char *pathified, *unixified, *cp;
6783
6784   if (path == NULL) return NULL;
6785   pathified = PerlMem_malloc(VMS_MAXRSS);
6786   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
6787   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6788     PerlMem_free(pathified);
6789     return NULL;
6790   }
6791
6792   unixified = NULL;
6793   if (buf == NULL) {
6794       Newx(unixified, VMS_MAXRSS, char);
6795   }
6796   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6797     PerlMem_free(pathified);
6798     if (unixified) Safefree(unixified);
6799     return NULL;
6800   }
6801   PerlMem_free(pathified);
6802   if (buf) {
6803     return buf;
6804   }
6805   else if (ts) {
6806     unixlen = strlen(unixified);
6807     Newx(cp,unixlen+1,char);
6808     memcpy(cp,unixified,unixlen);
6809     cp[unixlen] = '\0';
6810     Safefree(unixified);
6811     return cp;
6812   }
6813   else {
6814     strcpy(__tounixpath_retbuf,unixified);
6815     Safefree(unixified);
6816     return __tounixpath_retbuf;
6817   }
6818
6819 }  /* end of do_tounixpath() */
6820 /*}}}*/
6821 /* External entry points */
6822 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6823 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6824
6825 /*
6826  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
6827  *
6828  *****************************************************************************
6829  *                                                                           *
6830  *  Copyright (C) 1989-1994 by                                               *
6831  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
6832  *                                                                           *
6833  *  Permission is hereby  granted for the reproduction of this software,     *
6834  *  on condition that this copyright notice is included in the reproduction, *
6835  *  and that such reproduction is not for purposes of profit or material     *
6836  *  gain.                                                                    *
6837  *                                                                           *
6838  *  27-Aug-1994 Modified for inclusion in perl5                              *
6839  *              by Charles Bailey  bailey@newman.upenn.edu                   *
6840  *****************************************************************************
6841  */
6842
6843 /*
6844  * getredirection() is intended to aid in porting C programs
6845  * to VMS (Vax-11 C).  The native VMS environment does not support
6846  * '>' and '<' I/O redirection, or command line wild card expansion,
6847  * or a command line pipe mechanism using the '|' AND background
6848  * command execution '&'.  All of these capabilities are provided to any
6849  * C program which calls this procedure as the first thing in the
6850  * main program.
6851  * The piping mechanism will probably work with almost any 'filter' type
6852  * of program.  With suitable modification, it may useful for other
6853  * portability problems as well.
6854  *
6855  * Author:  Mark Pizzolato      mark@infocomm.com
6856  */
6857 struct list_item
6858     {
6859     struct list_item *next;
6860     char *value;
6861     };
6862
6863 static void add_item(struct list_item **head,
6864                      struct list_item **tail,
6865                      char *value,
6866                      int *count);
6867
6868 static void mp_expand_wild_cards(pTHX_ char *item,
6869                                 struct list_item **head,
6870                                 struct list_item **tail,
6871                                 int *count);
6872
6873 static int background_process(pTHX_ int argc, char **argv);
6874
6875 static void pipe_and_fork(pTHX_ char **cmargv);
6876
6877 /*{{{ void getredirection(int *ac, char ***av)*/
6878 static void
6879 mp_getredirection(pTHX_ int *ac, char ***av)
6880 /*
6881  * Process vms redirection arg's.  Exit if any error is seen.
6882  * If getredirection() processes an argument, it is erased
6883  * from the vector.  getredirection() returns a new argc and argv value.
6884  * In the event that a background command is requested (by a trailing "&"),
6885  * this routine creates a background subprocess, and simply exits the program.
6886  *
6887  * Warning: do not try to simplify the code for vms.  The code
6888  * presupposes that getredirection() is called before any data is
6889  * read from stdin or written to stdout.
6890  *
6891  * Normal usage is as follows:
6892  *
6893  *      main(argc, argv)
6894  *      int             argc;
6895  *      char            *argv[];
6896  *      {
6897  *              getredirection(&argc, &argv);
6898  *      }
6899  */
6900 {
6901     int                 argc = *ac;     /* Argument Count         */
6902     char                **argv = *av;   /* Argument Vector        */
6903     char                *ap;            /* Argument pointer       */
6904     int                 j;              /* argv[] index           */
6905     int                 item_count = 0; /* Count of Items in List */
6906     struct list_item    *list_head = 0; /* First Item in List       */
6907     struct list_item    *list_tail;     /* Last Item in List        */
6908     char                *in = NULL;     /* Input File Name          */
6909     char                *out = NULL;    /* Output File Name         */
6910     char                *outmode = "w"; /* Mode to Open Output File */
6911     char                *err = NULL;    /* Error File Name          */
6912     char                *errmode = "w"; /* Mode to Open Error File  */
6913     int                 cmargc = 0;     /* Piped Command Arg Count  */
6914     char                **cmargv = NULL;/* Piped Command Arg Vector */
6915
6916     /*
6917      * First handle the case where the last thing on the line ends with
6918      * a '&'.  This indicates the desire for the command to be run in a
6919      * subprocess, so we satisfy that desire.
6920      */
6921     ap = argv[argc-1];
6922     if (0 == strcmp("&", ap))
6923        exit(background_process(aTHX_ --argc, argv));
6924     if (*ap && '&' == ap[strlen(ap)-1])
6925         {
6926         ap[strlen(ap)-1] = '\0';
6927        exit(background_process(aTHX_ argc, argv));
6928         }
6929     /*
6930      * Now we handle the general redirection cases that involve '>', '>>',
6931      * '<', and pipes '|'.
6932      */
6933     for (j = 0; j < argc; ++j)
6934         {
6935         if (0 == strcmp("<", argv[j]))
6936             {
6937             if (j+1 >= argc)
6938                 {
6939                 fprintf(stderr,"No input file after < on command line");
6940                 exit(LIB$_WRONUMARG);
6941                 }
6942             in = argv[++j];
6943             continue;
6944             }
6945         if ('<' == *(ap = argv[j]))
6946             {
6947             in = 1 + ap;
6948             continue;
6949             }
6950         if (0 == strcmp(">", ap))
6951             {
6952             if (j+1 >= argc)
6953                 {
6954                 fprintf(stderr,"No output file after > on command line");
6955                 exit(LIB$_WRONUMARG);
6956                 }
6957             out = argv[++j];
6958             continue;
6959             }
6960         if ('>' == *ap)
6961             {
6962             if ('>' == ap[1])
6963                 {
6964                 outmode = "a";
6965                 if ('\0' == ap[2])
6966                     out = argv[++j];
6967                 else
6968                     out = 2 + ap;
6969                 }
6970             else
6971                 out = 1 + ap;
6972             if (j >= argc)
6973                 {
6974                 fprintf(stderr,"No output file after > or >> on command line");
6975                 exit(LIB$_WRONUMARG);
6976                 }
6977             continue;
6978             }
6979         if (('2' == *ap) && ('>' == ap[1]))
6980             {
6981             if ('>' == ap[2])
6982                 {
6983                 errmode = "a";
6984                 if ('\0' == ap[3])
6985                     err = argv[++j];
6986                 else
6987                     err = 3 + ap;
6988                 }
6989             else
6990                 if ('\0' == ap[2])
6991                     err = argv[++j];
6992                 else
6993                     err = 2 + ap;
6994             if (j >= argc)
6995                 {
6996                 fprintf(stderr,"No output file after 2> or 2>> on command line");
6997                 exit(LIB$_WRONUMARG);
6998                 }
6999             continue;
7000             }
7001         if (0 == strcmp("|", argv[j]))
7002             {
7003             if (j+1 >= argc)
7004                 {
7005                 fprintf(stderr,"No command into which to pipe on command line");
7006                 exit(LIB$_WRONUMARG);
7007                 }
7008             cmargc = argc-(j+1);
7009             cmargv = &argv[j+1];
7010             argc = j;
7011             continue;
7012             }
7013         if ('|' == *(ap = argv[j]))
7014             {
7015             ++argv[j];
7016             cmargc = argc-j;
7017             cmargv = &argv[j];
7018             argc = j;
7019             continue;
7020             }
7021         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7022         }
7023     /*
7024      * Allocate and fill in the new argument vector, Some Unix's terminate
7025      * the list with an extra null pointer.
7026      */
7027     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7028     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7029     *av = argv;
7030     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7031         argv[j] = list_head->value;
7032     *ac = item_count;
7033     if (cmargv != NULL)
7034         {
7035         if (out != NULL)
7036             {
7037             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7038             exit(LIB$_INVARGORD);
7039             }
7040         pipe_and_fork(aTHX_ cmargv);
7041         }
7042
7043     /* Check for input from a pipe (mailbox) */
7044
7045     if (in == NULL && 1 == isapipe(0))
7046         {
7047         char mbxname[L_tmpnam];
7048         long int bufsize;
7049         long int dvi_item = DVI$_DEVBUFSIZ;
7050         $DESCRIPTOR(mbxnam, "");
7051         $DESCRIPTOR(mbxdevnam, "");
7052
7053         /* Input from a pipe, reopen it in binary mode to disable       */
7054         /* carriage control processing.                                 */
7055
7056         fgetname(stdin, mbxname);
7057         mbxnam.dsc$a_pointer = mbxname;
7058         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7059         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7060         mbxdevnam.dsc$a_pointer = mbxname;
7061         mbxdevnam.dsc$w_length = sizeof(mbxname);
7062         dvi_item = DVI$_DEVNAM;
7063         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7064         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7065         set_errno(0);
7066         set_vaxc_errno(1);
7067         freopen(mbxname, "rb", stdin);
7068         if (errno != 0)
7069             {
7070             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7071             exit(vaxc$errno);
7072             }
7073         }
7074     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7075         {
7076         fprintf(stderr,"Can't open input file %s as stdin",in);
7077         exit(vaxc$errno);
7078         }
7079     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7080         {
7081         fprintf(stderr,"Can't open output file %s as stdout",out);
7082         exit(vaxc$errno);
7083         }
7084         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7085
7086     if (err != NULL) {
7087         if (strcmp(err,"&1") == 0) {
7088             dup2(fileno(stdout), fileno(stderr));
7089             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7090         } else {
7091         FILE *tmperr;
7092         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7093             {
7094             fprintf(stderr,"Can't open error file %s as stderr",err);
7095             exit(vaxc$errno);
7096             }
7097             fclose(tmperr);
7098            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7099                 {
7100                 exit(vaxc$errno);
7101                 }
7102             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7103         }
7104         }
7105 #ifdef ARGPROC_DEBUG
7106     PerlIO_printf(Perl_debug_log, "Arglist:\n");
7107     for (j = 0; j < *ac;  ++j)
7108         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7109 #endif
7110    /* Clear errors we may have hit expanding wildcards, so they don't
7111       show up in Perl's $! later */
7112    set_errno(0); set_vaxc_errno(1);
7113 }  /* end of getredirection() */
7114 /*}}}*/
7115
7116 static void add_item(struct list_item **head,
7117                      struct list_item **tail,
7118                      char *value,
7119                      int *count)
7120 {
7121     if (*head == 0)
7122         {
7123         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7124         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7125         *tail = *head;
7126         }
7127     else {
7128         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7129         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7130         *tail = (*tail)->next;
7131         }
7132     (*tail)->value = value;
7133     ++(*count);
7134 }
7135
7136 static void mp_expand_wild_cards(pTHX_ char *item,
7137                               struct list_item **head,
7138                               struct list_item **tail,
7139                               int *count)
7140 {
7141 int expcount = 0;
7142 unsigned long int context = 0;
7143 int isunix = 0;
7144 int item_len = 0;
7145 char *had_version;
7146 char *had_device;
7147 int had_directory;
7148 char *devdir,*cp;
7149 char *vmsspec;
7150 $DESCRIPTOR(filespec, "");
7151 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7152 $DESCRIPTOR(resultspec, "");
7153 unsigned long int lff_flags = 0;
7154 int sts;
7155 int rms_sts;
7156
7157 #ifdef VMS_LONGNAME_SUPPORT
7158     lff_flags = LIB$M_FIL_LONG_NAMES;
7159 #endif
7160
7161     for (cp = item; *cp; cp++) {
7162         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7163         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7164     }
7165     if (!*cp || isspace(*cp))
7166         {
7167         add_item(head, tail, item, count);
7168         return;
7169         }
7170     else
7171         {
7172      /* "double quoted" wild card expressions pass as is */
7173      /* From DCL that means using e.g.:                  */
7174      /* perl program """perl.*"""                        */
7175      item_len = strlen(item);
7176      if ( '"' == *item && '"' == item[item_len-1] )
7177        {
7178        item++;
7179        item[item_len-2] = '\0';
7180        add_item(head, tail, item, count);
7181        return;
7182        }
7183      }
7184     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7185     resultspec.dsc$b_class = DSC$K_CLASS_D;
7186     resultspec.dsc$a_pointer = NULL;
7187     vmsspec = PerlMem_malloc(VMS_MAXRSS);
7188     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7189     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7190       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
7191     if (!isunix || !filespec.dsc$a_pointer)
7192       filespec.dsc$a_pointer = item;
7193     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7194     /*
7195      * Only return version specs, if the caller specified a version
7196      */
7197     had_version = strchr(item, ';');
7198     /*
7199      * Only return device and directory specs, if the caller specifed either.
7200      */
7201     had_device = strchr(item, ':');
7202     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7203
7204     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7205                                  (&filespec, &resultspec, &context,
7206                                   &defaultspec, 0, &rms_sts, &lff_flags)))
7207         {
7208         char *string;
7209         char *c;
7210
7211         string = PerlMem_malloc(resultspec.dsc$w_length+1);
7212         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7213         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7214         string[resultspec.dsc$w_length] = '\0';
7215         if (NULL == had_version)
7216             *(strrchr(string, ';')) = '\0';
7217         if ((!had_directory) && (had_device == NULL))
7218             {
7219             if (NULL == (devdir = strrchr(string, ']')))
7220                 devdir = strrchr(string, '>');
7221             strcpy(string, devdir + 1);
7222             }
7223         /*
7224          * Be consistent with what the C RTL has already done to the rest of
7225          * the argv items and lowercase all of these names.
7226          */
7227         if (!decc_efs_case_preserve) {
7228             for (c = string; *c; ++c)
7229             if (isupper(*c))
7230                 *c = tolower(*c);
7231         }
7232         if (isunix) trim_unixpath(string,item,1);
7233         add_item(head, tail, string, count);
7234         ++expcount;
7235     }
7236     PerlMem_free(vmsspec);
7237     if (sts != RMS$_NMF)
7238         {
7239         set_vaxc_errno(sts);
7240         switch (sts)
7241             {
7242             case RMS$_FNF: case RMS$_DNF:
7243                 set_errno(ENOENT); break;
7244             case RMS$_DIR:
7245                 set_errno(ENOTDIR); break;
7246             case RMS$_DEV:
7247                 set_errno(ENODEV); break;
7248             case RMS$_FNM: case RMS$_SYN:
7249                 set_errno(EINVAL); break;
7250             case RMS$_PRV:
7251                 set_errno(EACCES); break;
7252             default:
7253                 _ckvmssts_noperl(sts);
7254             }
7255         }
7256     if (expcount == 0)
7257         add_item(head, tail, item, count);
7258     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7259     _ckvmssts_noperl(lib$find_file_end(&context));
7260 }
7261
7262 static int child_st[2];/* Event Flag set when child process completes   */
7263
7264 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
7265
7266 static unsigned long int exit_handler(int *status)
7267 {
7268 short iosb[4];
7269
7270     if (0 == child_st[0])
7271         {
7272 #ifdef ARGPROC_DEBUG
7273         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7274 #endif
7275         fflush(stdout);     /* Have to flush pipe for binary data to    */
7276                             /* terminate properly -- <tp@mccall.com>    */
7277         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7278         sys$dassgn(child_chan);
7279         fclose(stdout);
7280         sys$synch(0, child_st);
7281         }
7282     return(1);
7283 }
7284
7285 static void sig_child(int chan)
7286 {
7287 #ifdef ARGPROC_DEBUG
7288     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7289 #endif
7290     if (child_st[0] == 0)
7291         child_st[0] = 1;
7292 }
7293
7294 static struct exit_control_block exit_block =
7295     {
7296     0,
7297     exit_handler,
7298     1,
7299     &exit_block.exit_status,
7300     0
7301     };
7302
7303 static void
7304 pipe_and_fork(pTHX_ char **cmargv)
7305 {
7306     PerlIO *fp;
7307     struct dsc$descriptor_s *vmscmd;
7308     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7309     int sts, j, l, ismcr, quote, tquote = 0;
7310
7311     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
7312     vms_execfree(vmscmd);
7313
7314     j = l = 0;
7315     p = subcmd;
7316     q = cmargv[0];
7317     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
7318               && toupper(*(q+2)) == 'R' && !*(q+3);
7319
7320     while (q && l < MAX_DCL_LINE_LENGTH) {
7321         if (!*q) {
7322             if (j > 0 && quote) {
7323                 *p++ = '"';
7324                 l++;
7325             }
7326             q = cmargv[++j];
7327             if (q) {
7328                 if (ismcr && j > 1) quote = 1;
7329                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
7330                 *p++ = ' ';
7331                 l++;
7332                 if (quote || tquote) {
7333                     *p++ = '"';
7334                     l++;
7335                 }
7336         }
7337         } else {
7338             if ((quote||tquote) && *q == '"') {
7339                 *p++ = '"';
7340                 l++;
7341         }
7342             *p++ = *q++;
7343             l++;
7344         }
7345     }
7346     *p = '\0';
7347
7348     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7349     if (fp == Nullfp) {
7350         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7351         }
7352 }
7353
7354 static int background_process(pTHX_ int argc, char **argv)
7355 {
7356 char command[MAX_DCL_SYMBOL + 1] = "$";
7357 $DESCRIPTOR(value, "");
7358 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7359 static $DESCRIPTOR(null, "NLA0:");
7360 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7361 char pidstring[80];
7362 $DESCRIPTOR(pidstr, "");
7363 int pid;
7364 unsigned long int flags = 17, one = 1, retsts;
7365 int len;
7366
7367     strcat(command, argv[0]);
7368     len = strlen(command);
7369     while (--argc && (len < MAX_DCL_SYMBOL))
7370         {
7371         strcat(command, " \"");
7372         strcat(command, *(++argv));
7373         strcat(command, "\"");
7374         len = strlen(command);
7375         }
7376     value.dsc$a_pointer = command;
7377     value.dsc$w_length = strlen(value.dsc$a_pointer);
7378     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7379     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7380     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7381         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7382     }
7383     else {
7384         _ckvmssts_noperl(retsts);
7385     }
7386 #ifdef ARGPROC_DEBUG
7387     PerlIO_printf(Perl_debug_log, "%s\n", command);
7388 #endif
7389     sprintf(pidstring, "%08X", pid);
7390     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7391     pidstr.dsc$a_pointer = pidstring;
7392     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7393     lib$set_symbol(&pidsymbol, &pidstr);
7394     return(SS$_NORMAL);
7395 }
7396 /*}}}*/
7397 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7398
7399
7400 /* OS-specific initialization at image activation (not thread startup) */
7401 /* Older VAXC header files lack these constants */
7402 #ifndef JPI$_RIGHTS_SIZE
7403 #  define JPI$_RIGHTS_SIZE 817
7404 #endif
7405 #ifndef KGB$M_SUBSYSTEM
7406 #  define KGB$M_SUBSYSTEM 0x8
7407 #endif
7408
7409 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7410
7411 /*{{{void vms_image_init(int *, char ***)*/
7412 void
7413 vms_image_init(int *argcp, char ***argvp)
7414 {
7415   char eqv[LNM$C_NAMLENGTH+1] = "";
7416   unsigned int len, tabct = 8, tabidx = 0;
7417   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7418   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7419   unsigned short int dummy, rlen;
7420   struct dsc$descriptor_s **tabvec;
7421 #if defined(PERL_IMPLICIT_CONTEXT)
7422   pTHX = NULL;
7423 #endif
7424   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
7425                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
7426                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7427                                  {          0,                0,    0,      0} };
7428
7429 #ifdef KILL_BY_SIGPRC
7430     Perl_csighandler_init();
7431 #endif
7432
7433   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7434   _ckvmssts_noperl(iosb[0]);
7435   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7436     if (iprv[i]) {           /* Running image installed with privs? */
7437       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
7438       will_taint = TRUE;
7439       break;
7440     }
7441   }
7442   /* Rights identifiers might trigger tainting as well. */
7443   if (!will_taint && (rlen || rsz)) {
7444     while (rlen < rsz) {
7445       /* We didn't get all the identifiers on the first pass.  Allocate a
7446        * buffer much larger than $GETJPI wants (rsz is size in bytes that
7447        * were needed to hold all identifiers at time of last call; we'll
7448        * allocate that many unsigned long ints), and go back and get 'em.
7449        * If it gave us less than it wanted to despite ample buffer space,
7450        * something's broken.  Is your system missing a system identifier?
7451        */
7452       if (rsz <= jpilist[1].buflen) {
7453          /* Perl_croak accvios when used this early in startup. */
7454          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7455                          rsz, (unsigned long) jpilist[1].buflen,
7456                          "Check your rights database for corruption.\n");
7457          exit(SS$_ABORT);
7458       }
7459       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7460       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7461       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7462       jpilist[1].buflen = rsz * sizeof(unsigned long int);
7463       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7464       _ckvmssts_noperl(iosb[0]);
7465     }
7466     mask = jpilist[1].bufadr;
7467     /* Check attribute flags for each identifier (2nd longword); protected
7468      * subsystem identifiers trigger tainting.
7469      */
7470     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7471       if (mask[i] & KGB$M_SUBSYSTEM) {
7472         will_taint = TRUE;
7473         break;
7474       }
7475     }
7476     if (mask != rlst) PerlMem_free(mask);
7477   }
7478
7479   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7480    * logical, some versions of the CRTL will add a phanthom /000000/
7481    * directory.  This needs to be removed.
7482    */
7483   if (decc_filename_unix_report) {
7484   char * zeros;
7485   int ulen;
7486     ulen = strlen(argvp[0][0]);
7487     if (ulen > 7) {
7488       zeros = strstr(argvp[0][0], "/000000/");
7489       if (zeros != NULL) {
7490         int mlen;
7491         mlen = ulen - (zeros - argvp[0][0]) - 7;
7492         memmove(zeros, &zeros[7], mlen);
7493         ulen = ulen - 7;
7494         argvp[0][0][ulen] = '\0';
7495       }
7496     }
7497     /* It also may have a trailing dot that needs to be removed otherwise
7498      * it will be converted to VMS mode incorrectly.
7499      */
7500     ulen--;
7501     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7502       argvp[0][0][ulen] = '\0';
7503   }
7504
7505   /* We need to use this hack to tell Perl it should run with tainting,
7506    * since its tainting flag may be part of the PL_curinterp struct, which
7507    * hasn't been allocated when vms_image_init() is called.
7508    */
7509   if (will_taint) {
7510     char **newargv, **oldargv;
7511     oldargv = *argvp;
7512     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7513     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7514     newargv[0] = oldargv[0];
7515     newargv[1] = PerlMem_malloc(3 * sizeof(char));
7516     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7517     strcpy(newargv[1], "-T");
7518     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7519     (*argcp)++;
7520     newargv[*argcp] = NULL;
7521     /* We orphan the old argv, since we don't know where it's come from,
7522      * so we don't know how to free it.
7523      */
7524     *argvp = newargv;
7525   }
7526   else {  /* Did user explicitly request tainting? */
7527     int i;
7528     char *cp, **av = *argvp;
7529     for (i = 1; i < *argcp; i++) {
7530       if (*av[i] != '-') break;
7531       for (cp = av[i]+1; *cp; cp++) {
7532         if (*cp == 'T') { will_taint = 1; break; }
7533         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7534                   strchr("DFIiMmx",*cp)) break;
7535       }
7536       if (will_taint) break;
7537     }
7538   }
7539
7540   for (tabidx = 0;
7541        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7542        tabidx++) {
7543     if (!tabidx) {
7544       tabvec = (struct dsc$descriptor_s **)
7545             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7546       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7547     }
7548     else if (tabidx >= tabct) {
7549       tabct += 8;
7550       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7551       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7552     }
7553     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7554     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7555     tabvec[tabidx]->dsc$w_length  = 0;
7556     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
7557     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
7558     tabvec[tabidx]->dsc$a_pointer = NULL;
7559     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7560   }
7561   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7562
7563   getredirection(argcp,argvp);
7564 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7565   {
7566 # include <reentrancy.h>
7567   decc$set_reentrancy(C$C_MULTITHREAD);
7568   }
7569 #endif
7570   return;
7571 }
7572 /*}}}*/
7573
7574
7575 /* trim_unixpath()
7576  * Trim Unix-style prefix off filespec, so it looks like what a shell
7577  * glob expansion would return (i.e. from specified prefix on, not
7578  * full path).  Note that returned filespec is Unix-style, regardless
7579  * of whether input filespec was VMS-style or Unix-style.
7580  *
7581  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7582  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
7583  * vector of options; at present, only bit 0 is used, and if set tells
7584  * trim unixpath to try the current default directory as a prefix when
7585  * presented with a possibly ambiguous ... wildcard.
7586  *
7587  * Returns !=0 on success, with trimmed filespec replacing contents of
7588  * fspec, and 0 on failure, with contents of fpsec unchanged.
7589  */
7590 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7591 int
7592 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7593 {
7594   char *unixified, *unixwild,
7595        *template, *base, *end, *cp1, *cp2;
7596   register int tmplen, reslen = 0, dirs = 0;
7597
7598   unixwild = PerlMem_malloc(VMS_MAXRSS);
7599   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
7600   if (!wildspec || !fspec) return 0;
7601   template = unixwild;
7602   if (strpbrk(wildspec,"]>:") != NULL) {
7603     if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7604         PerlMem_free(unixwild);
7605         return 0;
7606     }
7607   }
7608   else {
7609     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7610     unixwild[VMS_MAXRSS-1] = 0;
7611   }
7612   unixified = PerlMem_malloc(VMS_MAXRSS);
7613   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
7614   if (strpbrk(fspec,"]>:") != NULL) {
7615     if (do_tounixspec(fspec,unixified,0) == NULL) {
7616         PerlMem_free(unixwild);
7617         PerlMem_free(unixified);
7618         return 0;
7619     }
7620     else base = unixified;
7621     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7622      * check to see that final result fits into (isn't longer than) fspec */
7623     reslen = strlen(fspec);
7624   }
7625   else base = fspec;
7626
7627   /* No prefix or absolute path on wildcard, so nothing to remove */
7628   if (!*template || *template == '/') {
7629     PerlMem_free(unixwild);
7630     if (base == fspec) {
7631         PerlMem_free(unixified);
7632         return 1;
7633     }
7634     tmplen = strlen(unixified);
7635     if (tmplen > reslen) {
7636         PerlMem_free(unixified);
7637         return 0;  /* not enough space */
7638     }
7639     /* Copy unixified resultant, including trailing NUL */
7640     memmove(fspec,unixified,tmplen+1);
7641     PerlMem_free(unixified);
7642     return 1;
7643   }
7644
7645   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
7646   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7647     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7648     for (cp1 = end ;cp1 >= base; cp1--)
7649       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7650         { cp1++; break; }
7651     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7652     PerlMem_free(unixified);
7653     PerlMem_free(unixwild);
7654     return 1;
7655   }
7656   else {
7657     char *tpl, *lcres;
7658     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7659     int ells = 1, totells, segdirs, match;
7660     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7661                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7662
7663     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7664     totells = ells;
7665     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7666     tpl = PerlMem_malloc(VMS_MAXRSS);
7667     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
7668     if (ellipsis == template && opts & 1) {
7669       /* Template begins with an ellipsis.  Since we can't tell how many
7670        * directory names at the front of the resultant to keep for an
7671        * arbitrary starting point, we arbitrarily choose the current
7672        * default directory as a starting point.  If it's there as a prefix,
7673        * clip it off.  If not, fall through and act as if the leading
7674        * ellipsis weren't there (i.e. return shortest possible path that
7675        * could match template).
7676        */
7677       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7678           PerlMem_free(tpl);
7679           PerlMem_free(unixified);
7680           PerlMem_free(unixwild);
7681           return 0;
7682       }
7683       if (!decc_efs_case_preserve) {
7684         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7685           if (_tolower(*cp1) != _tolower(*cp2)) break;
7686       }
7687       segdirs = dirs - totells;  /* Min # of dirs we must have left */
7688       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7689       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7690         memmove(fspec,cp2+1,end - cp2);
7691         PerlMem_free(tpl);
7692         PerlMem_free(unixified);
7693         PerlMem_free(unixwild);
7694         return 1;
7695       }
7696     }
7697     /* First off, back up over constant elements at end of path */
7698     if (dirs) {
7699       for (front = end ; front >= base; front--)
7700          if (*front == '/' && !dirs--) { front++; break; }
7701     }
7702     lcres = PerlMem_malloc(VMS_MAXRSS);
7703     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
7704     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7705          cp1++,cp2++) {
7706             if (!decc_efs_case_preserve) {
7707                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
7708             }
7709             else {
7710                 *cp2 = *cp1;
7711             }
7712     }
7713     if (cp1 != '\0') {
7714         PerlMem_free(tpl);
7715         PerlMem_free(unixified);
7716         PerlMem_free(unixwild);
7717         PerlMem_free(lcres);
7718         return 0;  /* Path too long. */
7719     }
7720     lcend = cp2;
7721     *cp2 = '\0';  /* Pick up with memcpy later */
7722     lcfront = lcres + (front - base);
7723     /* Now skip over each ellipsis and try to match the path in front of it. */
7724     while (ells--) {
7725       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7726         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
7727             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
7728       if (cp1 < template) break; /* template started with an ellipsis */
7729       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7730         ellipsis = cp1; continue;
7731       }
7732       wilddsc.dsc$a_pointer = tpl;
7733       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7734       nextell = cp1;
7735       for (segdirs = 0, cp2 = tpl;
7736            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7737            cp1++, cp2++) {
7738          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7739          else {
7740             if (!decc_efs_case_preserve) {
7741               *cp2 = _tolower(*cp1);  /* else lowercase for match */
7742             }
7743             else {
7744               *cp2 = *cp1;  /* else preserve case for match */
7745             }
7746          }
7747          if (*cp2 == '/') segdirs++;
7748       }
7749       if (cp1 != ellipsis - 1) {
7750           PerlMem_free(tpl);
7751           PerlMem_free(unixified);
7752           PerlMem_free(unixwild);
7753           PerlMem_free(lcres);
7754           return 0; /* Path too long */
7755       }
7756       /* Back up at least as many dirs as in template before matching */
7757       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7758         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7759       for (match = 0; cp1 > lcres;) {
7760         resdsc.dsc$a_pointer = cp1;
7761         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7762           match++;
7763           if (match == 1) lcfront = cp1;
7764         }
7765         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7766       }
7767       if (!match) {
7768         PerlMem_free(tpl);
7769         PerlMem_free(unixified);
7770         PerlMem_free(unixwild);
7771         PerlMem_free(lcres);
7772         return 0;  /* Can't find prefix ??? */
7773       }
7774       if (match > 1 && opts & 1) {
7775         /* This ... wildcard could cover more than one set of dirs (i.e.
7776          * a set of similar dir names is repeated).  If the template
7777          * contains more than 1 ..., upstream elements could resolve the
7778          * ambiguity, but it's not worth a full backtracking setup here.
7779          * As a quick heuristic, clip off the current default directory
7780          * if it's present to find the trimmed spec, else use the
7781          * shortest string that this ... could cover.
7782          */
7783         char def[NAM$C_MAXRSS+1], *st;
7784
7785         if (getcwd(def, sizeof def,0) == NULL) {
7786             Safefree(unixified);
7787             Safefree(unixwild);
7788             Safefree(lcres);
7789             Safefree(tpl);
7790             return 0;
7791         }
7792         if (!decc_efs_case_preserve) {
7793           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7794             if (_tolower(*cp1) != _tolower(*cp2)) break;
7795         }
7796         segdirs = dirs - totells;  /* Min # of dirs we must have left */
7797         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7798         if (*cp1 == '\0' && *cp2 == '/') {
7799           memmove(fspec,cp2+1,end - cp2);
7800           PerlMem_free(tpl);
7801           PerlMem_free(unixified);
7802           PerlMem_free(unixwild);
7803           PerlMem_free(lcres);
7804           return 1;
7805         }
7806         /* Nope -- stick with lcfront from above and keep going. */
7807       }
7808     }
7809     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7810     PerlMem_free(tpl);
7811     PerlMem_free(unixified);
7812     PerlMem_free(unixwild);
7813     PerlMem_free(lcres);
7814     return 1;
7815     ellipsis = nextell;
7816   }
7817
7818 }  /* end of trim_unixpath() */
7819 /*}}}*/
7820
7821
7822 /*
7823  *  VMS readdir() routines.
7824  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7825  *
7826  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
7827  *  Minor modifications to original routines.
7828  */
7829
7830 /* readdir may have been redefined by reentr.h, so make sure we get
7831  * the local version for what we do here.
7832  */
7833 #ifdef readdir
7834 # undef readdir
7835 #endif
7836 #if !defined(PERL_IMPLICIT_CONTEXT)
7837 # define readdir Perl_readdir
7838 #else
7839 # define readdir(a) Perl_readdir(aTHX_ a)
7840 #endif
7841
7842     /* Number of elements in vms_versions array */
7843 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
7844
7845 /*
7846  *  Open a directory, return a handle for later use.
7847  */
7848 /*{{{ DIR *opendir(char*name) */
7849 DIR *
7850 Perl_opendir(pTHX_ const char *name)
7851 {
7852     DIR *dd;
7853     char *dir;
7854     Stat_t sb;
7855     int unix_flag;
7856
7857     unix_flag = 0;
7858     if (decc_efs_charset) {
7859         unix_flag = is_unix_filespec(name);
7860     }
7861
7862     Newx(dir, VMS_MAXRSS, char);
7863     if (do_tovmspath(name,dir,0) == NULL) {
7864       Safefree(dir);
7865       return NULL;
7866     }
7867     /* Check access before stat; otherwise stat does not
7868      * accurately report whether it's a directory.
7869      */
7870     if (!cando_by_name(S_IRUSR,0,dir)) {
7871       /* cando_by_name has already set errno */
7872       Safefree(dir);
7873       return NULL;
7874     }
7875     if (flex_stat(dir,&sb) == -1) return NULL;
7876     if (!S_ISDIR(sb.st_mode)) {
7877       Safefree(dir);
7878       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
7879       return NULL;
7880     }
7881     /* Get memory for the handle, and the pattern. */
7882     Newx(dd,1,DIR);
7883     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7884
7885     /* Fill in the fields; mainly playing with the descriptor. */
7886     sprintf(dd->pattern, "%s*.*",dir);
7887     Safefree(dir);
7888     dd->context = 0;
7889     dd->count = 0;
7890     dd->flags = 0;
7891     if (unix_flag)
7892         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
7893     dd->pat.dsc$a_pointer = dd->pattern;
7894     dd->pat.dsc$w_length = strlen(dd->pattern);
7895     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7896     dd->pat.dsc$b_class = DSC$K_CLASS_S;
7897 #if defined(USE_ITHREADS)
7898     Newx(dd->mutex,1,perl_mutex);
7899     MUTEX_INIT( (perl_mutex *) dd->mutex );
7900 #else
7901     dd->mutex = NULL;
7902 #endif
7903
7904     return dd;
7905 }  /* end of opendir() */
7906 /*}}}*/
7907
7908 /*
7909  *  Set the flag to indicate we want versions or not.
7910  */
7911 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7912 void
7913 vmsreaddirversions(DIR *dd, int flag)
7914 {
7915     if (flag)
7916         dd->flags |= PERL_VMSDIR_M_VERSIONS;
7917     else
7918         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
7919 }
7920 /*}}}*/
7921
7922 /*
7923  *  Free up an opened directory.
7924  */
7925 /*{{{ void closedir(DIR *dd)*/
7926 void
7927 Perl_closedir(DIR *dd)
7928 {
7929     int sts;
7930
7931     sts = lib$find_file_end(&dd->context);
7932     Safefree(dd->pattern);
7933 #if defined(USE_ITHREADS)
7934     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7935     Safefree(dd->mutex);
7936 #endif
7937     Safefree(dd);
7938 }
7939 /*}}}*/
7940
7941 /*
7942  *  Collect all the version numbers for the current file.
7943  */
7944 static void
7945 collectversions(pTHX_ DIR *dd)
7946 {
7947     struct dsc$descriptor_s     pat;
7948     struct dsc$descriptor_s     res;
7949     struct dirent *e;
7950     char *p, *text, *buff;
7951     int i;
7952     unsigned long context, tmpsts;
7953
7954     /* Convenient shorthand. */
7955     e = &dd->entry;
7956
7957     /* Add the version wildcard, ignoring the "*.*" put on before */
7958     i = strlen(dd->pattern);
7959     Newx(text,i + e->d_namlen + 3,char);
7960     strcpy(text, dd->pattern);
7961     sprintf(&text[i - 3], "%s;*", e->d_name);
7962
7963     /* Set up the pattern descriptor. */
7964     pat.dsc$a_pointer = text;
7965     pat.dsc$w_length = i + e->d_namlen - 1;
7966     pat.dsc$b_dtype = DSC$K_DTYPE_T;
7967     pat.dsc$b_class = DSC$K_CLASS_S;
7968
7969     /* Set up result descriptor. */
7970     Newx(buff, VMS_MAXRSS, char);
7971     res.dsc$a_pointer = buff;
7972     res.dsc$w_length = VMS_MAXRSS - 1;
7973     res.dsc$b_dtype = DSC$K_DTYPE_T;
7974     res.dsc$b_class = DSC$K_CLASS_S;
7975
7976     /* Read files, collecting versions. */
7977     for (context = 0, e->vms_verscount = 0;
7978          e->vms_verscount < VERSIZE(e);
7979          e->vms_verscount++) {
7980         unsigned long rsts;
7981         unsigned long flags = 0;
7982
7983 #ifdef VMS_LONGNAME_SUPPORT
7984         flags = LIB$M_FIL_LONG_NAMES
7985 #endif
7986         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
7987         if (tmpsts == RMS$_NMF || context == 0) break;
7988         _ckvmssts(tmpsts);
7989         buff[VMS_MAXRSS - 1] = '\0';
7990         if ((p = strchr(buff, ';')))
7991             e->vms_versions[e->vms_verscount] = atoi(p + 1);
7992         else
7993             e->vms_versions[e->vms_verscount] = -1;
7994     }
7995
7996     _ckvmssts(lib$find_file_end(&context));
7997     Safefree(text);
7998     Safefree(buff);
7999
8000 }  /* end of collectversions() */
8001
8002 /*
8003  *  Read the next entry from the directory.
8004  */
8005 /*{{{ struct dirent *readdir(DIR *dd)*/
8006 struct dirent *
8007 Perl_readdir(pTHX_ DIR *dd)
8008 {
8009     struct dsc$descriptor_s     res;
8010     char *p, *buff;
8011     unsigned long int tmpsts;
8012     unsigned long rsts;
8013     unsigned long flags = 0;
8014     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8015     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8016
8017     /* Set up result descriptor, and get next file. */
8018     Newx(buff, VMS_MAXRSS, char);
8019     res.dsc$a_pointer = buff;
8020     res.dsc$w_length = VMS_MAXRSS - 1;
8021     res.dsc$b_dtype = DSC$K_DTYPE_T;
8022     res.dsc$b_class = DSC$K_CLASS_S;
8023
8024 #ifdef VMS_LONGNAME_SUPPORT
8025     flags = LIB$M_FIL_LONG_NAMES
8026 #endif
8027
8028     tmpsts = lib$find_file
8029         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8030     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8031     if (!(tmpsts & 1)) {
8032       set_vaxc_errno(tmpsts);
8033       switch (tmpsts) {
8034         case RMS$_PRV:
8035           set_errno(EACCES); break;
8036         case RMS$_DEV:
8037           set_errno(ENODEV); break;
8038         case RMS$_DIR:
8039           set_errno(ENOTDIR); break;
8040         case RMS$_FNF: case RMS$_DNF:
8041           set_errno(ENOENT); break;
8042         default:
8043           set_errno(EVMSERR);
8044       }
8045       Safefree(buff);
8046       return NULL;
8047     }
8048     dd->count++;
8049     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8050     if (!decc_efs_case_preserve) {
8051       buff[VMS_MAXRSS - 1] = '\0';
8052       for (p = buff; *p; p++) *p = _tolower(*p);
8053     }
8054     else {
8055       /* we don't want to force to lowercase, just null terminate */
8056       buff[res.dsc$w_length] = '\0';
8057     }
8058     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8059     *p = '\0';
8060
8061     /* Skip any directory component and just copy the name. */
8062     sts = vms_split_path
8063        (aTHX_ buff,
8064         &v_spec,
8065         &v_len,
8066         &r_spec,
8067         &r_len,
8068         &d_spec,
8069         &d_len,
8070         &n_spec,
8071         &n_len,
8072         &e_spec,
8073         &e_len,
8074         &vs_spec,
8075         &vs_len);
8076
8077     /* Drop NULL extensions on UNIX file specification */
8078     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8079         (e_len == 1) && decc_readdir_dropdotnotype)) {
8080         e_len = 0;
8081         e_spec[0] = '\0';
8082     }
8083
8084     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8085     dd->entry.d_name[n_len + e_len] = '\0';
8086     dd->entry.d_namlen = strlen(dd->entry.d_name);
8087
8088     /* Convert the filename to UNIX format if needed */
8089     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8090
8091         /* Translate the encoded characters. */
8092         /* Fixme: unicode handling could result in embedded 0 characters */
8093         if (strchr(dd->entry.d_name, '^') != NULL) {
8094             char new_name[256];
8095             char * q;
8096             int cnt;
8097             p = dd->entry.d_name;
8098             q = new_name;
8099             while (*p != 0) {
8100                 int x, y;
8101                 x = copy_expand_vms_filename_escape(q, p, &y);
8102                 p += x;
8103                 q += y;
8104                 /* fix-me */
8105                 /* if y > 1, then this is a wide file specification */
8106                 /* Wide file specifications need to be passed in Perl */
8107                 /* counted strings apparently with a unicode flag */
8108             }
8109             *q = 0;
8110             strcpy(dd->entry.d_name, new_name);
8111         }
8112     }
8113
8114     dd->entry.vms_verscount = 0;
8115     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8116     Safefree(buff);
8117     return &dd->entry;
8118
8119 }  /* end of readdir() */
8120 /*}}}*/
8121
8122 /*
8123  *  Read the next entry from the directory -- thread-safe version.
8124  */
8125 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8126 int
8127 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8128 {
8129     int retval;
8130
8131     MUTEX_LOCK( (perl_mutex *) dd->mutex );
8132
8133     entry = readdir(dd);
8134     *result = entry;
8135     retval = ( *result == NULL ? errno : 0 );
8136
8137     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8138
8139     return retval;
8140
8141 }  /* end of readdir_r() */
8142 /*}}}*/
8143
8144 /*
8145  *  Return something that can be used in a seekdir later.
8146  */
8147 /*{{{ long telldir(DIR *dd)*/
8148 long
8149 Perl_telldir(DIR *dd)
8150 {
8151     return dd->count;
8152 }
8153 /*}}}*/
8154
8155 /*
8156  *  Return to a spot where we used to be.  Brute force.
8157  */
8158 /*{{{ void seekdir(DIR *dd,long count)*/
8159 void
8160 Perl_seekdir(pTHX_ DIR *dd, long count)
8161 {
8162     int old_flags;
8163
8164     /* If we haven't done anything yet... */
8165     if (dd->count == 0)
8166         return;
8167
8168     /* Remember some state, and clear it. */
8169     old_flags = dd->flags;
8170     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8171     _ckvmssts(lib$find_file_end(&dd->context));
8172     dd->context = 0;
8173
8174     /* The increment is in readdir(). */
8175     for (dd->count = 0; dd->count < count; )
8176         readdir(dd);
8177
8178     dd->flags = old_flags;
8179
8180 }  /* end of seekdir() */
8181 /*}}}*/
8182
8183 /* VMS subprocess management
8184  *
8185  * my_vfork() - just a vfork(), after setting a flag to record that
8186  * the current script is trying a Unix-style fork/exec.
8187  *
8188  * vms_do_aexec() and vms_do_exec() are called in response to the
8189  * perl 'exec' function.  If this follows a vfork call, then they
8190  * call out the regular perl routines in doio.c which do an
8191  * execvp (for those who really want to try this under VMS).
8192  * Otherwise, they do exactly what the perl docs say exec should
8193  * do - terminate the current script and invoke a new command
8194  * (See below for notes on command syntax.)
8195  *
8196  * do_aspawn() and do_spawn() implement the VMS side of the perl
8197  * 'system' function.
8198  *
8199  * Note on command arguments to perl 'exec' and 'system': When handled
8200  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8201  * are concatenated to form a DCL command string.  If the first arg
8202  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8203  * the command string is handed off to DCL directly.  Otherwise,
8204  * the first token of the command is taken as the filespec of an image
8205  * to run.  The filespec is expanded using a default type of '.EXE' and
8206  * the process defaults for device, directory, etc., and if found, the resultant
8207  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8208  * the command string as parameters.  This is perhaps a bit complicated,
8209  * but I hope it will form a happy medium between what VMS folks expect
8210  * from lib$spawn and what Unix folks expect from exec.
8211  */
8212
8213 static int vfork_called;
8214
8215 /*{{{int my_vfork()*/
8216 int
8217 my_vfork()
8218 {
8219   vfork_called++;
8220   return vfork();
8221 }
8222 /*}}}*/
8223
8224
8225 static void
8226 vms_execfree(struct dsc$descriptor_s *vmscmd)
8227 {
8228   if (vmscmd) {
8229       if (vmscmd->dsc$a_pointer) {
8230           PerlMem_free(vmscmd->dsc$a_pointer);
8231       }
8232       PerlMem_free(vmscmd);
8233   }
8234 }
8235
8236 static char *
8237 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8238 {
8239   char *junk, *tmps = Nullch;
8240   register size_t cmdlen = 0;
8241   size_t rlen;
8242   register SV **idx;
8243   STRLEN n_a;
8244
8245   idx = mark;
8246   if (really) {
8247     tmps = SvPV(really,rlen);
8248     if (*tmps) {
8249       cmdlen += rlen + 1;
8250       idx++;
8251     }
8252   }
8253
8254   for (idx++; idx <= sp; idx++) {
8255     if (*idx) {
8256       junk = SvPVx(*idx,rlen);
8257       cmdlen += rlen ? rlen + 1 : 0;
8258     }
8259   }
8260   Newx(PL_Cmd, cmdlen+1, char);
8261
8262   if (tmps && *tmps) {
8263     strcpy(PL_Cmd,tmps);
8264     mark++;
8265   }
8266   else *PL_Cmd = '\0';
8267   while (++mark <= sp) {
8268     if (*mark) {
8269       char *s = SvPVx(*mark,n_a);
8270       if (!*s) continue;
8271       if (*PL_Cmd) strcat(PL_Cmd," ");
8272       strcat(PL_Cmd,s);
8273     }
8274   }
8275   return PL_Cmd;
8276
8277 }  /* end of setup_argstr() */
8278
8279
8280 static unsigned long int
8281 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8282                    struct dsc$descriptor_s **pvmscmd)
8283 {
8284   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8285   char image_name[NAM$C_MAXRSS+1];
8286   char image_argv[NAM$C_MAXRSS+1];
8287   $DESCRIPTOR(defdsc,".EXE");
8288   $DESCRIPTOR(defdsc2,".");
8289   $DESCRIPTOR(resdsc,resspec);
8290   struct dsc$descriptor_s *vmscmd;
8291   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8292   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8293   register char *s, *rest, *cp, *wordbreak;
8294   char * cmd;
8295   int cmdlen;
8296   register int isdcl;
8297
8298   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8299   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8300
8301   /* Make a copy for modification */
8302   cmdlen = strlen(incmd);
8303   cmd = PerlMem_malloc(cmdlen+1);
8304   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8305   strncpy(cmd, incmd, cmdlen);
8306   cmd[cmdlen] = 0;
8307   image_name[0] = 0;
8308   image_argv[0] = 0;
8309
8310   vmscmd->dsc$a_pointer = NULL;
8311   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
8312   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
8313   vmscmd->dsc$w_length = 0;
8314   if (pvmscmd) *pvmscmd = vmscmd;
8315
8316   if (suggest_quote) *suggest_quote = 0;
8317
8318   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8319     PerlMem_free(cmd);
8320     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
8321   }
8322
8323   s = cmd;
8324
8325   while (*s && isspace(*s)) s++;
8326
8327   if (*s == '@' || *s == '$') {
8328     vmsspec[0] = *s;  rest = s + 1;
8329     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8330   }
8331   else { cp = vmsspec; rest = s; }
8332   if (*rest == '.' || *rest == '/') {
8333     char *cp2;
8334     for (cp2 = resspec;
8335          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8336          rest++, cp2++) *cp2 = *rest;
8337     *cp2 = '\0';
8338     if (do_tovmsspec(resspec,cp,0)) {
8339       s = vmsspec;
8340       if (*rest) {
8341         for (cp2 = vmsspec + strlen(vmsspec);
8342              *rest && cp2 - vmsspec < sizeof vmsspec;
8343              rest++, cp2++) *cp2 = *rest;
8344         *cp2 = '\0';
8345       }
8346     }
8347   }
8348   /* Intuit whether verb (first word of cmd) is a DCL command:
8349    *   - if first nonspace char is '@', it's a DCL indirection
8350    * otherwise
8351    *   - if verb contains a filespec separator, it's not a DCL command
8352    *   - if it doesn't, caller tells us whether to default to a DCL
8353    *     command, or to a local image unless told it's DCL (by leading '$')
8354    */
8355   if (*s == '@') {
8356       isdcl = 1;
8357       if (suggest_quote) *suggest_quote = 1;
8358   } else {
8359     register char *filespec = strpbrk(s,":<[.;");
8360     rest = wordbreak = strpbrk(s," \"\t/");
8361     if (!wordbreak) wordbreak = s + strlen(s);
8362     if (*s == '$') check_img = 0;
8363     if (filespec && (filespec < wordbreak)) isdcl = 0;
8364     else isdcl = !check_img;
8365   }
8366
8367   if (!isdcl) {
8368     int rsts;
8369     imgdsc.dsc$a_pointer = s;
8370     imgdsc.dsc$w_length = wordbreak - s;
8371     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8372     if (!(retsts&1)) {
8373         _ckvmssts(lib$find_file_end(&cxt));
8374         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8375       if (!(retsts & 1) && *s == '$') {
8376         _ckvmssts(lib$find_file_end(&cxt));
8377         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8378         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8379         if (!(retsts&1)) {
8380           _ckvmssts(lib$find_file_end(&cxt));
8381           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8382         }
8383       }
8384     }
8385     _ckvmssts(lib$find_file_end(&cxt));
8386
8387     if (retsts & 1) {
8388       FILE *fp;
8389       s = resspec;
8390       while (*s && !isspace(*s)) s++;
8391       *s = '\0';
8392
8393       /* check that it's really not DCL with no file extension */
8394       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8395       if (fp) {
8396         char b[256] = {0,0,0,0};
8397         read(fileno(fp), b, 256);
8398         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
8399         if (isdcl) {
8400           int shebang_len;
8401
8402           /* Check for script */
8403           shebang_len = 0;
8404           if ((b[0] == '#') && (b[1] == '!'))
8405              shebang_len = 2;
8406 #ifdef ALTERNATE_SHEBANG
8407           else {
8408             shebang_len = strlen(ALTERNATE_SHEBANG);
8409             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
8410               char * perlstr;
8411                 perlstr = strstr("perl",b);
8412                 if (perlstr == NULL)
8413                   shebang_len = 0;
8414             }
8415             else
8416               shebang_len = 0;
8417           }
8418 #endif
8419
8420           if (shebang_len > 0) {
8421           int i;
8422           int j;
8423           char tmpspec[NAM$C_MAXRSS + 1];
8424
8425             i = shebang_len;
8426              /* Image is following after white space */
8427             /*--------------------------------------*/
8428             while (isprint(b[i]) && isspace(b[i]))
8429                 i++;
8430
8431             j = 0;
8432             while (isprint(b[i]) && !isspace(b[i])) {
8433                 tmpspec[j++] = b[i++];
8434                 if (j >= NAM$C_MAXRSS)
8435                    break;
8436             }
8437             tmpspec[j] = '\0';
8438
8439              /* There may be some default parameters to the image */
8440             /*---------------------------------------------------*/
8441             j = 0;
8442             while (isprint(b[i])) {
8443                 image_argv[j++] = b[i++];
8444                 if (j >= NAM$C_MAXRSS)
8445                    break;
8446             }
8447             while ((j > 0) && !isprint(image_argv[j-1]))
8448                 j--;
8449             image_argv[j] = 0;
8450
8451             /* It will need to be converted to VMS format and validated */
8452             if (tmpspec[0] != '\0') {
8453               char * iname;
8454
8455                /* Try to find the exact program requested to be run */
8456               /*---------------------------------------------------*/
8457               iname = do_rmsexpand
8458                   (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8459               if (iname != NULL) {
8460                 if (cando_by_name(S_IXUSR,0,image_name)) {
8461                   /* MCR prefix needed */
8462                   isdcl = 0;
8463                 }
8464                 else {
8465                    /* Try again with a null type */
8466                   /*----------------------------*/
8467                   iname = do_rmsexpand
8468                     (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8469                   if (iname != NULL) {
8470                     if (cando_by_name(S_IXUSR,0,image_name)) {
8471                       /* MCR prefix needed */
8472                       isdcl = 0;
8473                     }
8474                   }
8475                 }
8476
8477                  /* Did we find the image to run the script? */
8478                 /*------------------------------------------*/
8479                 if (isdcl) {
8480                   char *tchr;
8481
8482                    /* Assume DCL or foreign command exists */
8483                   /*--------------------------------------*/
8484                   tchr = strrchr(tmpspec, '/');
8485                   if (tchr != NULL) {
8486                     tchr++;
8487                   }
8488                   else {
8489                     tchr = tmpspec;
8490                   }
8491                   strcpy(image_name, tchr);
8492                 }
8493               }
8494             }
8495           }
8496         }
8497         fclose(fp);
8498       }
8499       if (check_img && isdcl) return RMS$_FNF;
8500
8501       if (cando_by_name(S_IXUSR,0,resspec)) {
8502         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
8503         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
8504         if (!isdcl) {
8505             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8506             if (image_name[0] != 0) {
8507                 strcat(vmscmd->dsc$a_pointer, image_name);
8508                 strcat(vmscmd->dsc$a_pointer, " ");
8509             }
8510         } else if (image_name[0] != 0) {
8511             strcpy(vmscmd->dsc$a_pointer, image_name);
8512             strcat(vmscmd->dsc$a_pointer, " ");
8513         } else {
8514             strcpy(vmscmd->dsc$a_pointer,"@");
8515         }
8516         if (suggest_quote) *suggest_quote = 1;
8517
8518         /* If there is an image name, use original command */
8519         if (image_name[0] == 0)
8520             strcat(vmscmd->dsc$a_pointer,resspec);
8521         else {
8522             rest = cmd;
8523             while (*rest && isspace(*rest)) rest++;
8524         }
8525
8526         if (image_argv[0] != 0) {
8527           strcat(vmscmd->dsc$a_pointer,image_argv);
8528           strcat(vmscmd->dsc$a_pointer, " ");
8529         }
8530         if (rest) {
8531            int rest_len;
8532            int vmscmd_len;
8533
8534            rest_len = strlen(rest);
8535            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8536            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8537               strcat(vmscmd->dsc$a_pointer,rest);
8538            else
8539              retsts = CLI$_BUFOVF;
8540         }
8541         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8542         PerlMem_free(cmd);
8543         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8544       }
8545       else
8546         retsts = RMS$_PRV;
8547     }
8548   }
8549   /* It's either a DCL command or we couldn't find a suitable image */
8550   vmscmd->dsc$w_length = strlen(cmd);
8551
8552   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
8553   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
8554   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
8555
8556   PerlMem_free(cmd);
8557
8558   /* check if it's a symbol (for quoting purposes) */
8559   if (suggest_quote && !*suggest_quote) {
8560     int iss;
8561     char equiv[LNM$C_NAMLENGTH];
8562     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8563     eqvdsc.dsc$a_pointer = equiv;
8564
8565     iss = lib$get_symbol(vmscmd,&eqvdsc);
8566     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8567   }
8568   if (!(retsts & 1)) {
8569     /* just hand off status values likely to be due to user error */
8570     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8571         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8572        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8573     else { _ckvmssts(retsts); }
8574   }
8575
8576   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8577
8578 }  /* end of setup_cmddsc() */
8579
8580
8581 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8582 bool
8583 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8584 {
8585 bool exec_sts;
8586 char * cmd;
8587
8588   if (sp > mark) {
8589     if (vfork_called) {           /* this follows a vfork - act Unixish */
8590       vfork_called--;
8591       if (vfork_called < 0) {
8592         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8593         vfork_called = 0;
8594       }
8595       else return do_aexec(really,mark,sp);
8596     }
8597                                            /* no vfork - act VMSish */
8598     cmd = setup_argstr(aTHX_ really,mark,sp);
8599     exec_sts = vms_do_exec(cmd);
8600     Safefree(cmd);  /* Clean up from setup_argstr() */
8601     return exec_sts;
8602   }
8603
8604   return FALSE;
8605 }  /* end of vms_do_aexec() */
8606 /*}}}*/
8607
8608 /* {{{bool vms_do_exec(char *cmd) */
8609 bool
8610 Perl_vms_do_exec(pTHX_ const char *cmd)
8611 {
8612   struct dsc$descriptor_s *vmscmd;
8613
8614   if (vfork_called) {             /* this follows a vfork - act Unixish */
8615     vfork_called--;
8616     if (vfork_called < 0) {
8617       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8618       vfork_called = 0;
8619     }
8620     else return do_exec(cmd);
8621   }
8622
8623   {                               /* no vfork - act VMSish */
8624     unsigned long int retsts;
8625
8626     TAINT_ENV();
8627     TAINT_PROPER("exec");
8628     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8629       retsts = lib$do_command(vmscmd);
8630
8631     switch (retsts) {
8632       case RMS$_FNF: case RMS$_DNF:
8633         set_errno(ENOENT); break;
8634       case RMS$_DIR:
8635         set_errno(ENOTDIR); break;
8636       case RMS$_DEV:
8637         set_errno(ENODEV); break;
8638       case RMS$_PRV:
8639         set_errno(EACCES); break;
8640       case RMS$_SYN:
8641         set_errno(EINVAL); break;
8642       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8643         set_errno(E2BIG); break;
8644       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8645         _ckvmssts(retsts); /* fall through */
8646       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8647         set_errno(EVMSERR);
8648     }
8649     set_vaxc_errno(retsts);
8650     if (ckWARN(WARN_EXEC)) {
8651       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8652              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8653     }
8654     vms_execfree(vmscmd);
8655   }
8656
8657   return FALSE;
8658
8659 }  /* end of vms_do_exec() */
8660 /*}}}*/
8661
8662 unsigned long int Perl_do_spawn(pTHX_ const char *);
8663
8664 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8665 unsigned long int
8666 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8667 {
8668 unsigned long int sts;
8669 char * cmd;
8670
8671   if (sp > mark) {
8672     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
8673     sts = do_spawn(cmd);
8674     /* pp_sys will clean up cmd */
8675     return sts;
8676   }
8677   return SS$_ABORT;
8678 }  /* end of do_aspawn() */
8679 /*}}}*/
8680
8681 /* {{{unsigned long int do_spawn(char *cmd) */
8682 unsigned long int
8683 Perl_do_spawn(pTHX_ const char *cmd)
8684 {
8685   unsigned long int sts, substs;
8686
8687   /* The caller of this routine expects to Safefree(PL_Cmd) */
8688   Newx(PL_Cmd,10,char);
8689
8690   TAINT_ENV();
8691   TAINT_PROPER("spawn");
8692   if (!cmd || !*cmd) {
8693     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8694     if (!(sts & 1)) {
8695       switch (sts) {
8696         case RMS$_FNF:  case RMS$_DNF:
8697           set_errno(ENOENT); break;
8698         case RMS$_DIR:
8699           set_errno(ENOTDIR); break;
8700         case RMS$_DEV:
8701           set_errno(ENODEV); break;
8702         case RMS$_PRV:
8703           set_errno(EACCES); break;
8704         case RMS$_SYN:
8705           set_errno(EINVAL); break;
8706         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8707           set_errno(E2BIG); break;
8708         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8709           _ckvmssts(sts); /* fall through */
8710         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8711           set_errno(EVMSERR);
8712       }
8713       set_vaxc_errno(sts);
8714       if (ckWARN(WARN_EXEC)) {
8715         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8716                     Strerror(errno));
8717       }
8718     }
8719     sts = substs;
8720   }
8721   else {
8722     PerlIO * fp;
8723     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8724     if (fp != NULL)
8725       my_pclose(fp);
8726   }
8727   return sts;
8728 }  /* end of do_spawn() */
8729 /*}}}*/
8730
8731
8732 static unsigned int *sockflags, sockflagsize;
8733
8734 /*
8735  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8736  * routines found in some versions of the CRTL can't deal with sockets.
8737  * We don't shim the other file open routines since a socket isn't
8738  * likely to be opened by a name.
8739  */
8740 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8741 FILE *my_fdopen(int fd, const char *mode)
8742 {
8743   FILE *fp = fdopen(fd, mode);
8744
8745   if (fp) {
8746     unsigned int fdoff = fd / sizeof(unsigned int);
8747     Stat_t sbuf; /* native stat; we don't need flex_stat */
8748     if (!sockflagsize || fdoff > sockflagsize) {
8749       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
8750       else           Newx  (sockflags,fdoff+2,unsigned int);
8751       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8752       sockflagsize = fdoff + 2;
8753     }
8754     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8755       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8756   }
8757   return fp;
8758
8759 }
8760 /*}}}*/
8761
8762
8763 /*
8764  * Clear the corresponding bit when the (possibly) socket stream is closed.
8765  * There still a small hole: we miss an implicit close which might occur
8766  * via freopen().  >> Todo
8767  */
8768 /*{{{ int my_fclose(FILE *fp)*/
8769 int my_fclose(FILE *fp) {
8770   if (fp) {
8771     unsigned int fd = fileno(fp);
8772     unsigned int fdoff = fd / sizeof(unsigned int);
8773
8774     if (sockflagsize && fdoff <= sockflagsize)
8775       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8776   }
8777   return fclose(fp);
8778 }
8779 /*}}}*/
8780
8781
8782 /*
8783  * A simple fwrite replacement which outputs itmsz*nitm chars without
8784  * introducing record boundaries every itmsz chars.
8785  * We are using fputs, which depends on a terminating null.  We may
8786  * well be writing binary data, so we need to accommodate not only
8787  * data with nulls sprinkled in the middle but also data with no null
8788  * byte at the end.
8789  */
8790 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8791 int
8792 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8793 {
8794   register char *cp, *end, *cpd, *data;
8795   register unsigned int fd = fileno(dest);
8796   register unsigned int fdoff = fd / sizeof(unsigned int);
8797   int retval;
8798   int bufsize = itmsz * nitm + 1;
8799
8800   if (fdoff < sockflagsize &&
8801       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8802     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8803     return nitm;
8804   }
8805
8806   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8807   memcpy( data, src, itmsz*nitm );
8808   data[itmsz*nitm] = '\0';
8809
8810   end = data + itmsz * nitm;
8811   retval = (int) nitm; /* on success return # items written */
8812
8813   cpd = data;
8814   while (cpd <= end) {
8815     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8816     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8817     if (cp < end)
8818       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8819     cpd = cp + 1;
8820   }
8821
8822   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8823   return retval;
8824
8825 }  /* end of my_fwrite() */
8826 /*}}}*/
8827
8828 /*{{{ int my_flush(FILE *fp)*/
8829 int
8830 Perl_my_flush(pTHX_ FILE *fp)
8831 {
8832     int res;
8833     if ((res = fflush(fp)) == 0 && fp) {
8834 #ifdef VMS_DO_SOCKETS
8835         Stat_t s;
8836         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8837 #endif
8838             res = fsync(fileno(fp));
8839     }
8840 /*
8841  * If the flush succeeded but set end-of-file, we need to clear
8842  * the error because our caller may check ferror().  BTW, this
8843  * probably means we just flushed an empty file.
8844  */
8845     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8846
8847     return res;
8848 }
8849 /*}}}*/
8850
8851 /*
8852  * Here are replacements for the following Unix routines in the VMS environment:
8853  *      getpwuid    Get information for a particular UIC or UID
8854  *      getpwnam    Get information for a named user
8855  *      getpwent    Get information for each user in the rights database
8856  *      setpwent    Reset search to the start of the rights database
8857  *      endpwent    Finish searching for users in the rights database
8858  *
8859  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8860  * (defined in pwd.h), which contains the following fields:-
8861  *      struct passwd {
8862  *              char        *pw_name;    Username (in lower case)
8863  *              char        *pw_passwd;  Hashed password
8864  *              unsigned int pw_uid;     UIC
8865  *              unsigned int pw_gid;     UIC group  number
8866  *              char        *pw_unixdir; Default device/directory (VMS-style)
8867  *              char        *pw_gecos;   Owner name
8868  *              char        *pw_dir;     Default device/directory (Unix-style)
8869  *              char        *pw_shell;   Default CLI name (eg. DCL)
8870  *      };
8871  * If the specified user does not exist, getpwuid and getpwnam return NULL.
8872  *
8873  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8874  * not the UIC member number (eg. what's returned by getuid()),
8875  * getpwuid() can accept either as input (if uid is specified, the caller's
8876  * UIC group is used), though it won't recognise gid=0.
8877  *
8878  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8879  * information about other users in your group or in other groups, respectively.
8880  * If the required privilege is not available, then these routines fill only
8881  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8882  * string).
8883  *
8884  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8885  */
8886
8887 /* sizes of various UAF record fields */
8888 #define UAI$S_USERNAME 12
8889 #define UAI$S_IDENT    31
8890 #define UAI$S_OWNER    31
8891 #define UAI$S_DEFDEV   31
8892 #define UAI$S_DEFDIR   63
8893 #define UAI$S_DEFCLI   31
8894 #define UAI$S_PWD       8
8895
8896 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
8897                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8898                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
8899
8900 static char __empty[]= "";
8901 static struct passwd __passwd_empty=
8902     {(char *) __empty, (char *) __empty, 0, 0,
8903      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8904 static int contxt= 0;
8905 static struct passwd __pwdcache;
8906 static char __pw_namecache[UAI$S_IDENT+1];
8907
8908 /*
8909  * This routine does most of the work extracting the user information.
8910  */
8911 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8912 {
8913     static struct {
8914         unsigned char length;
8915         char pw_gecos[UAI$S_OWNER+1];
8916     } owner;
8917     static union uicdef uic;
8918     static struct {
8919         unsigned char length;
8920         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8921     } defdev;
8922     static struct {
8923         unsigned char length;
8924         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8925     } defdir;
8926     static struct {
8927         unsigned char length;
8928         char pw_shell[UAI$S_DEFCLI+1];
8929     } defcli;
8930     static char pw_passwd[UAI$S_PWD+1];
8931
8932     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8933     struct dsc$descriptor_s name_desc;
8934     unsigned long int sts;
8935
8936     static struct itmlst_3 itmlst[]= {
8937         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
8938         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
8939         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
8940         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
8941         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
8942         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
8943         {0,                0,           NULL,    NULL}};
8944
8945     name_desc.dsc$w_length=  strlen(name);
8946     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8947     name_desc.dsc$b_class=   DSC$K_CLASS_S;
8948     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8949
8950 /*  Note that sys$getuai returns many fields as counted strings. */
8951     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8952     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8953       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8954     }
8955     else { _ckvmssts(sts); }
8956     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
8957
8958     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
8959     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8960     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8961     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8962     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8963     owner.pw_gecos[lowner]=            '\0';
8964     defdev.pw_dir[ldefdev+ldefdir]= '\0';
8965     defcli.pw_shell[ldefcli]=          '\0';
8966     if (valid_uic(uic)) {
8967         pwd->pw_uid= uic.uic$l_uic;
8968         pwd->pw_gid= uic.uic$v_group;
8969     }
8970     else
8971       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8972     pwd->pw_passwd=  pw_passwd;
8973     pwd->pw_gecos=   owner.pw_gecos;
8974     pwd->pw_dir=     defdev.pw_dir;
8975     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8976     pwd->pw_shell=   defcli.pw_shell;
8977     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8978         int ldir;
8979         ldir= strlen(pwd->pw_unixdir) - 1;
8980         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8981     }
8982     else
8983         strcpy(pwd->pw_unixdir, pwd->pw_dir);
8984     if (!decc_efs_case_preserve)
8985         __mystrtolower(pwd->pw_unixdir);
8986     return 1;
8987 }
8988
8989 /*
8990  * Get information for a named user.
8991 */
8992 /*{{{struct passwd *getpwnam(char *name)*/
8993 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8994 {
8995     struct dsc$descriptor_s name_desc;
8996     union uicdef uic;
8997     unsigned long int status, sts;
8998
8999     __pwdcache = __passwd_empty;
9000     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9001       /* We still may be able to determine pw_uid and pw_gid */
9002       name_desc.dsc$w_length=  strlen(name);
9003       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9004       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9005       name_desc.dsc$a_pointer= (char *) name;
9006       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9007         __pwdcache.pw_uid= uic.uic$l_uic;
9008         __pwdcache.pw_gid= uic.uic$v_group;
9009       }
9010       else {
9011         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9012           set_vaxc_errno(sts);
9013           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9014           return NULL;
9015         }
9016         else { _ckvmssts(sts); }
9017       }
9018     }
9019     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9020     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9021     __pwdcache.pw_name= __pw_namecache;
9022     return &__pwdcache;
9023 }  /* end of my_getpwnam() */
9024 /*}}}*/
9025
9026 /*
9027  * Get information for a particular UIC or UID.
9028  * Called by my_getpwent with uid=-1 to list all users.
9029 */
9030 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9031 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9032 {
9033     const $DESCRIPTOR(name_desc,__pw_namecache);
9034     unsigned short lname;
9035     union uicdef uic;
9036     unsigned long int status;
9037
9038     if (uid == (unsigned int) -1) {
9039       do {
9040         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9041         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9042           set_vaxc_errno(status);
9043           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9044           my_endpwent();
9045           return NULL;
9046         }
9047         else { _ckvmssts(status); }
9048       } while (!valid_uic (uic));
9049     }
9050     else {
9051       uic.uic$l_uic= uid;
9052       if (!uic.uic$v_group)
9053         uic.uic$v_group= PerlProc_getgid();
9054       if (valid_uic(uic))
9055         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9056       else status = SS$_IVIDENT;
9057       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9058           status == RMS$_PRV) {
9059         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9060         return NULL;
9061       }
9062       else { _ckvmssts(status); }
9063     }
9064     __pw_namecache[lname]= '\0';
9065     __mystrtolower(__pw_namecache);
9066
9067     __pwdcache = __passwd_empty;
9068     __pwdcache.pw_name = __pw_namecache;
9069
9070 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9071     The identifier's value is usually the UIC, but it doesn't have to be,
9072     so if we can, we let fillpasswd update this. */
9073     __pwdcache.pw_uid =  uic.uic$l_uic;
9074     __pwdcache.pw_gid =  uic.uic$v_group;
9075
9076     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9077     return &__pwdcache;
9078
9079 }  /* end of my_getpwuid() */
9080 /*}}}*/
9081
9082 /*
9083  * Get information for next user.
9084 */
9085 /*{{{struct passwd *my_getpwent()*/
9086 struct passwd *Perl_my_getpwent(pTHX)
9087 {
9088     return (my_getpwuid((unsigned int) -1));
9089 }
9090 /*}}}*/
9091
9092 /*
9093  * Finish searching rights database for users.
9094 */
9095 /*{{{void my_endpwent()*/
9096 void Perl_my_endpwent(pTHX)
9097 {
9098     if (contxt) {
9099       _ckvmssts(sys$finish_rdb(&contxt));
9100       contxt= 0;
9101     }
9102 }
9103 /*}}}*/
9104
9105 #ifdef HOMEGROWN_POSIX_SIGNALS
9106   /* Signal handling routines, pulled into the core from POSIX.xs.
9107    *
9108    * We need these for threads, so they've been rolled into the core,
9109    * rather than left in POSIX.xs.
9110    *
9111    * (DRS, Oct 23, 1997)
9112    */
9113
9114   /* sigset_t is atomic under VMS, so these routines are easy */
9115 /*{{{int my_sigemptyset(sigset_t *) */
9116 int my_sigemptyset(sigset_t *set) {
9117     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9118     *set = 0; return 0;
9119 }
9120 /*}}}*/
9121
9122
9123 /*{{{int my_sigfillset(sigset_t *)*/
9124 int my_sigfillset(sigset_t *set) {
9125     int i;
9126     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9127     for (i = 0; i < NSIG; i++) *set |= (1 << i);
9128     return 0;
9129 }
9130 /*}}}*/
9131
9132
9133 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9134 int my_sigaddset(sigset_t *set, int sig) {
9135     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9136     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9137     *set |= (1 << (sig - 1));
9138     return 0;
9139 }
9140 /*}}}*/
9141
9142
9143 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9144 int my_sigdelset(sigset_t *set, int sig) {
9145     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9146     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9147     *set &= ~(1 << (sig - 1));
9148     return 0;
9149 }
9150 /*}}}*/
9151
9152
9153 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9154 int my_sigismember(sigset_t *set, int sig) {
9155     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9156     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9157     return *set & (1 << (sig - 1));
9158 }
9159 /*}}}*/
9160
9161
9162 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9163 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9164     sigset_t tempmask;
9165
9166     /* If set and oset are both null, then things are badly wrong. Bail out. */
9167     if ((oset == NULL) && (set == NULL)) {
9168       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9169       return -1;
9170     }
9171
9172     /* If set's null, then we're just handling a fetch. */
9173     if (set == NULL) {
9174         tempmask = sigblock(0);
9175     }
9176     else {
9177       switch (how) {
9178       case SIG_SETMASK:
9179         tempmask = sigsetmask(*set);
9180         break;
9181       case SIG_BLOCK:
9182         tempmask = sigblock(*set);
9183         break;
9184       case SIG_UNBLOCK:
9185         tempmask = sigblock(0);
9186         sigsetmask(*oset & ~tempmask);
9187         break;
9188       default:
9189         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9190         return -1;
9191       }
9192     }
9193
9194     /* Did they pass us an oset? If so, stick our holding mask into it */
9195     if (oset)
9196       *oset = tempmask;
9197
9198     return 0;
9199 }
9200 /*}}}*/
9201 #endif  /* HOMEGROWN_POSIX_SIGNALS */
9202
9203
9204 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9205  * my_utime(), and flex_stat(), all of which operate on UTC unless
9206  * VMSISH_TIMES is true.
9207  */
9208 /* method used to handle UTC conversions:
9209  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
9210  */
9211 static int gmtime_emulation_type;
9212 /* number of secs to add to UTC POSIX-style time to get local time */
9213 static long int utc_offset_secs;
9214
9215 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9216  * in vmsish.h.  #undef them here so we can call the CRTL routines
9217  * directly.
9218  */
9219 #undef gmtime
9220 #undef localtime
9221 #undef time
9222
9223
9224 /*
9225  * DEC C previous to 6.0 corrupts the behavior of the /prefix
9226  * qualifier with the extern prefix pragma.  This provisional
9227  * hack circumvents this prefix pragma problem in previous
9228  * precompilers.
9229  */
9230 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9231 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9232 #    pragma __extern_prefix save
9233 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
9234 #    define gmtime decc$__utctz_gmtime
9235 #    define localtime decc$__utctz_localtime
9236 #    define time decc$__utc_time
9237 #    pragma __extern_prefix restore
9238
9239      struct tm *gmtime(), *localtime();
9240
9241 #  endif
9242 #endif
9243
9244
9245 static time_t toutc_dst(time_t loc) {
9246   struct tm *rsltmp;
9247
9248   if ((rsltmp = localtime(&loc)) == NULL) return -1;
9249   loc -= utc_offset_secs;
9250   if (rsltmp->tm_isdst) loc -= 3600;
9251   return loc;
9252 }
9253 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9254        ((gmtime_emulation_type || my_time(NULL)), \
9255        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9256        ((secs) - utc_offset_secs))))
9257
9258 static time_t toloc_dst(time_t utc) {
9259   struct tm *rsltmp;
9260
9261   utc += utc_offset_secs;
9262   if ((rsltmp = localtime(&utc)) == NULL) return -1;
9263   if (rsltmp->tm_isdst) utc += 3600;
9264   return utc;
9265 }
9266 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9267        ((gmtime_emulation_type || my_time(NULL)), \
9268        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9269        ((secs) + utc_offset_secs))))
9270
9271 #ifndef RTL_USES_UTC
9272 /*
9273
9274     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
9275         DST starts on 1st sun of april      at 02:00  std time
9276             ends on last sun of october     at 02:00  dst time
9277     see the UCX management command reference, SET CONFIG TIMEZONE
9278     for formatting info.
9279
9280     No, it's not as general as it should be, but then again, NOTHING
9281     will handle UK times in a sensible way.
9282 */
9283
9284
9285 /*
9286     parse the DST start/end info:
9287     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9288 */
9289
9290 static char *
9291 tz_parse_startend(char *s, struct tm *w, int *past)
9292 {
9293     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9294     int ly, dozjd, d, m, n, hour, min, sec, j, k;
9295     time_t g;
9296
9297     if (!s)    return 0;
9298     if (!w) return 0;
9299     if (!past) return 0;
9300
9301     ly = 0;
9302     if (w->tm_year % 4        == 0) ly = 1;
9303     if (w->tm_year % 100      == 0) ly = 0;
9304     if (w->tm_year+1900 % 400 == 0) ly = 1;
9305     if (ly) dinm[1]++;
9306
9307     dozjd = isdigit(*s);
9308     if (*s == 'J' || *s == 'j' || dozjd) {
9309         if (!dozjd && !isdigit(*++s)) return 0;
9310         d = *s++ - '0';
9311         if (isdigit(*s)) {
9312             d = d*10 + *s++ - '0';
9313             if (isdigit(*s)) {
9314                 d = d*10 + *s++ - '0';
9315             }
9316         }
9317         if (d == 0) return 0;
9318         if (d > 366) return 0;
9319         d--;
9320         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
9321         g = d * 86400;
9322         dozjd = 1;
9323     } else if (*s == 'M' || *s == 'm') {
9324         if (!isdigit(*++s)) return 0;
9325         m = *s++ - '0';
9326         if (isdigit(*s)) m = 10*m + *s++ - '0';
9327         if (*s != '.') return 0;
9328         if (!isdigit(*++s)) return 0;
9329         n = *s++ - '0';
9330         if (n < 1 || n > 5) return 0;
9331         if (*s != '.') return 0;
9332         if (!isdigit(*++s)) return 0;
9333         d = *s++ - '0';
9334         if (d > 6) return 0;
9335     }
9336
9337     if (*s == '/') {
9338         if (!isdigit(*++s)) return 0;
9339         hour = *s++ - '0';
9340         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9341         if (*s == ':') {
9342             if (!isdigit(*++s)) return 0;
9343             min = *s++ - '0';
9344             if (isdigit(*s)) min = 10*min + *s++ - '0';
9345             if (*s == ':') {
9346                 if (!isdigit(*++s)) return 0;
9347                 sec = *s++ - '0';
9348                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9349             }
9350         }
9351     } else {
9352         hour = 2;
9353         min = 0;
9354         sec = 0;
9355     }
9356
9357     if (dozjd) {
9358         if (w->tm_yday < d) goto before;
9359         if (w->tm_yday > d) goto after;
9360     } else {
9361         if (w->tm_mon+1 < m) goto before;
9362         if (w->tm_mon+1 > m) goto after;
9363
9364         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
9365         k = d - j; /* mday of first d */
9366         if (k <= 0) k += 7;
9367         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
9368         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9369         if (w->tm_mday < k) goto before;
9370         if (w->tm_mday > k) goto after;
9371     }
9372
9373     if (w->tm_hour < hour) goto before;
9374     if (w->tm_hour > hour) goto after;
9375     if (w->tm_min  < min)  goto before;
9376     if (w->tm_min  > min)  goto after;
9377     if (w->tm_sec  < sec)  goto before;
9378     goto after;
9379
9380 before:
9381     *past = 0;
9382     return s;
9383 after:
9384     *past = 1;
9385     return s;
9386 }
9387
9388
9389
9390
9391 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
9392
9393 static char *
9394 tz_parse_offset(char *s, int *offset)
9395 {
9396     int hour = 0, min = 0, sec = 0;
9397     int neg = 0;
9398     if (!s) return 0;
9399     if (!offset) return 0;
9400
9401     if (*s == '-') {neg++; s++;}
9402     if (*s == '+') s++;
9403     if (!isdigit(*s)) return 0;
9404     hour = *s++ - '0';
9405     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
9406     if (hour > 24) return 0;
9407     if (*s == ':') {
9408         if (!isdigit(*++s)) return 0;
9409         min = *s++ - '0';
9410         if (isdigit(*s)) min = min*10 + (*s++ - '0');
9411         if (min > 59) return 0;
9412         if (*s == ':') {
9413             if (!isdigit(*++s)) return 0;
9414             sec = *s++ - '0';
9415             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
9416             if (sec > 59) return 0;
9417         }
9418     }
9419
9420     *offset = (hour*60+min)*60 + sec;
9421     if (neg) *offset = -*offset;
9422     return s;
9423 }
9424
9425 /*
9426     input time is w, whatever type of time the CRTL localtime() uses.
9427     sets dst, the zone, and the gmtoff (seconds)
9428
9429     caches the value of TZ and UCX$TZ env variables; note that
9430     my_setenv looks for these and sets a flag if they're changed
9431     for efficiency.
9432
9433     We have to watch out for the "australian" case (dst starts in
9434     october, ends in april)...flagged by "reverse" and checked by
9435     scanning through the months of the previous year.
9436
9437 */
9438
9439 static int
9440 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
9441 {
9442     time_t when;
9443     struct tm *w2;
9444     char *s,*s2;
9445     char *dstzone, *tz, *s_start, *s_end;
9446     int std_off, dst_off, isdst;
9447     int y, dststart, dstend;
9448     static char envtz[1025];  /* longer than any logical, symbol, ... */
9449     static char ucxtz[1025];
9450     static char reversed = 0;
9451
9452     if (!w) return 0;
9453
9454     if (tz_updated) {
9455         tz_updated = 0;
9456         reversed = -1;  /* flag need to check  */
9457         envtz[0] = ucxtz[0] = '\0';
9458         tz = my_getenv("TZ",0);
9459         if (tz) strcpy(envtz, tz);
9460         tz = my_getenv("UCX$TZ",0);
9461         if (tz) strcpy(ucxtz, tz);
9462         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
9463     }
9464     tz = envtz;
9465     if (!*tz) tz = ucxtz;
9466
9467     s = tz;
9468     while (isalpha(*s)) s++;
9469     s = tz_parse_offset(s, &std_off);
9470     if (!s) return 0;
9471     if (!*s) {                  /* no DST, hurray we're done! */
9472         isdst = 0;
9473         goto done;
9474     }
9475
9476     dstzone = s;
9477     while (isalpha(*s)) s++;
9478     s2 = tz_parse_offset(s, &dst_off);
9479     if (s2) {
9480         s = s2;
9481     } else {
9482         dst_off = std_off - 3600;
9483     }
9484
9485     if (!*s) {      /* default dst start/end?? */
9486         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
9487             s = strchr(ucxtz,',');
9488         }
9489         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
9490     }
9491     if (*s != ',') return 0;
9492
9493     when = *w;
9494     when = _toutc(when);      /* convert to utc */
9495     when = when - std_off;    /* convert to pseudolocal time*/
9496
9497     w2 = localtime(&when);
9498     y = w2->tm_year;
9499     s_start = s+1;
9500     s = tz_parse_startend(s_start,w2,&dststart);
9501     if (!s) return 0;
9502     if (*s != ',') return 0;
9503
9504     when = *w;
9505     when = _toutc(when);      /* convert to utc */
9506     when = when - dst_off;    /* convert to pseudolocal time*/
9507     w2 = localtime(&when);
9508     if (w2->tm_year != y) {   /* spans a year, just check one time */
9509         when += dst_off - std_off;
9510         w2 = localtime(&when);
9511     }
9512     s_end = s+1;
9513     s = tz_parse_startend(s_end,w2,&dstend);
9514     if (!s) return 0;
9515
9516     if (reversed == -1) {  /* need to check if start later than end */
9517         int j, ds, de;
9518
9519         when = *w;
9520         if (when < 2*365*86400) {
9521             when += 2*365*86400;
9522         } else {
9523             when -= 365*86400;
9524         }
9525         w2 =localtime(&when);
9526         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
9527
9528         for (j = 0; j < 12; j++) {
9529             w2 =localtime(&when);
9530             tz_parse_startend(s_start,w2,&ds);
9531             tz_parse_startend(s_end,w2,&de);
9532             if (ds != de) break;
9533             when += 30*86400;
9534         }
9535         reversed = 0;
9536         if (de && !ds) reversed = 1;
9537     }
9538
9539     isdst = dststart && !dstend;
9540     if (reversed) isdst = dststart  || !dstend;
9541
9542 done:
9543     if (dst)    *dst = isdst;
9544     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9545     if (isdst)  tz = dstzone;
9546     if (zone) {
9547         while(isalpha(*tz))  *zone++ = *tz++;
9548         *zone = '\0';
9549     }
9550     return 1;
9551 }
9552
9553 #endif /* !RTL_USES_UTC */
9554
9555 /* my_time(), my_localtime(), my_gmtime()
9556  * By default traffic in UTC time values, using CRTL gmtime() or
9557  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9558  * Note: We need to use these functions even when the CRTL has working
9559  * UTC support, since they also handle C<use vmsish qw(times);>
9560  *
9561  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
9562  * Modified by Charles Bailey <bailey@newman.upenn.edu>
9563  */
9564
9565 /*{{{time_t my_time(time_t *timep)*/
9566 time_t Perl_my_time(pTHX_ time_t *timep)
9567 {
9568   time_t when;
9569   struct tm *tm_p;
9570
9571   if (gmtime_emulation_type == 0) {
9572     int dstnow;
9573     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
9574                               /* results of calls to gmtime() and localtime() */
9575                               /* for same &base */
9576
9577     gmtime_emulation_type++;
9578     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9579       char off[LNM$C_NAMLENGTH+1];;
9580
9581       gmtime_emulation_type++;
9582       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9583         gmtime_emulation_type++;
9584         utc_offset_secs = 0;
9585         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9586       }
9587       else { utc_offset_secs = atol(off); }
9588     }
9589     else { /* We've got a working gmtime() */
9590       struct tm gmt, local;
9591
9592       gmt = *tm_p;
9593       tm_p = localtime(&base);
9594       local = *tm_p;
9595       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
9596       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9597       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
9598       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
9599     }
9600   }
9601
9602   when = time(NULL);
9603 # ifdef VMSISH_TIME
9604 # ifdef RTL_USES_UTC
9605   if (VMSISH_TIME) when = _toloc(when);
9606 # else
9607   if (!VMSISH_TIME) when = _toutc(when);
9608 # endif
9609 # endif
9610   if (timep != NULL) *timep = when;
9611   return when;
9612
9613 }  /* end of my_time() */
9614 /*}}}*/
9615
9616
9617 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9618 struct tm *
9619 Perl_my_gmtime(pTHX_ const time_t *timep)
9620 {
9621   char *p;
9622   time_t when;
9623   struct tm *rsltmp;
9624
9625   if (timep == NULL) {
9626     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9627     return NULL;
9628   }
9629   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9630
9631   when = *timep;
9632 # ifdef VMSISH_TIME
9633   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9634 #  endif
9635 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
9636   return gmtime(&when);
9637 # else
9638   /* CRTL localtime() wants local time as input, so does no tz correction */
9639   rsltmp = localtime(&when);
9640   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
9641   return rsltmp;
9642 #endif
9643 }  /* end of my_gmtime() */
9644 /*}}}*/
9645
9646
9647 /*{{{struct tm *my_localtime(const time_t *timep)*/
9648 struct tm *
9649 Perl_my_localtime(pTHX_ const time_t *timep)
9650 {
9651   time_t when, whenutc;
9652   struct tm *rsltmp;
9653   int dst, offset;
9654
9655   if (timep == NULL) {
9656     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9657     return NULL;
9658   }
9659   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9660   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9661
9662   when = *timep;
9663 # ifdef RTL_USES_UTC
9664 # ifdef VMSISH_TIME
9665   if (VMSISH_TIME) when = _toutc(when);
9666 # endif
9667   /* CRTL localtime() wants UTC as input, does tz correction itself */
9668   return localtime(&when);
9669
9670 # else /* !RTL_USES_UTC */
9671   whenutc = when;
9672 # ifdef VMSISH_TIME
9673   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
9674   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
9675 # endif
9676   dst = -1;
9677 #ifndef RTL_USES_UTC
9678   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
9679       when = whenutc - offset;                   /* pseudolocal time*/
9680   }
9681 # endif
9682   /* CRTL localtime() wants local time as input, so does no tz correction */
9683   rsltmp = localtime(&when);
9684   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9685   return rsltmp;
9686 # endif
9687
9688 } /*  end of my_localtime() */
9689 /*}}}*/
9690
9691 /* Reset definitions for later calls */
9692 #define gmtime(t)    my_gmtime(t)
9693 #define localtime(t) my_localtime(t)
9694 #define time(t)      my_time(t)
9695
9696
9697 /* my_utime - update modification time of a file
9698  * calling sequence is identical to POSIX utime(), but under
9699  * VMS only the modification time is changed; ODS-2 does not
9700  * maintain access times.  Restrictions differ from the POSIX
9701  * definition in that the time can be changed as long as the
9702  * caller has permission to execute the necessary IO$_MODIFY $QIO;
9703  * no separate checks are made to insure that the caller is the
9704  * owner of the file or has special privs enabled.
9705  * Code here is based on Joe Meadows' FILE utility.
9706  */
9707
9708 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9709  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
9710  * in 100 ns intervals.
9711  */
9712 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9713
9714 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9715 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9716 {
9717   register int i;
9718   int sts;
9719   long int bintime[2], len = 2, lowbit, unixtime,
9720            secscale = 10000000; /* seconds --> 100 ns intervals */
9721   unsigned long int chan, iosb[2], retsts;
9722   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9723   struct FAB myfab = cc$rms_fab;
9724   struct NAM mynam = cc$rms_nam;
9725 #if defined (__DECC) && defined (__VAX)
9726   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9727    * at least through VMS V6.1, which causes a type-conversion warning.
9728    */
9729 #  pragma message save
9730 #  pragma message disable cvtdiftypes
9731 #endif
9732   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9733   struct fibdef myfib;
9734 #if defined (__DECC) && defined (__VAX)
9735   /* This should be right after the declaration of myatr, but due
9736    * to a bug in VAX DEC C, this takes effect a statement early.
9737    */
9738 #  pragma message restore
9739 #endif
9740   /* cast ok for read only parameter */
9741   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9742                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9743                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9744
9745   if (decc_efs_charset != 0) {
9746     struct utimbuf utc_utimes;
9747
9748     utc_utimes.actime = utimes->actime;
9749     utc_utimes.modtime = utimes->modtime;
9750 #   ifdef VMSISH_TIME
9751     /* If input was local; convert to UTC for sys svc */
9752     if (VMSISH_TIME) {
9753         utc_utimes.actime = _toutc(utimes->actime);
9754         utc_utimes.modtime = _toutc(utimes->modtime);
9755     }
9756 #   endif
9757     sts = utime(file, &utc_utimes);
9758     return sts;
9759   }
9760
9761   if (file == NULL || *file == '\0') {
9762     set_errno(ENOENT);
9763     set_vaxc_errno(LIB$_INVARG);
9764     return -1;
9765   }
9766
9767   /* Convert to VMS format ensuring that it will fit in 255 characters */
9768   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL)
9769         return -1;
9770
9771   if (utimes != NULL) {
9772     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
9773      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9774      * Since time_t is unsigned long int, and lib$emul takes a signed long int
9775      * as input, we force the sign bit to be clear by shifting unixtime right
9776      * one bit, then multiplying by an extra factor of 2 in lib$emul().
9777      */
9778     lowbit = (utimes->modtime & 1) ? secscale : 0;
9779     unixtime = (long int) utimes->modtime;
9780 #   ifdef VMSISH_TIME
9781     /* If input was UTC; convert to local for sys svc */
9782     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9783 #   endif
9784     unixtime >>= 1;  secscale <<= 1;
9785     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9786     if (!(retsts & 1)) {
9787       set_errno(EVMSERR);
9788       set_vaxc_errno(retsts);
9789       return -1;
9790     }
9791     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9792     if (!(retsts & 1)) {
9793       set_errno(EVMSERR);
9794       set_vaxc_errno(retsts);
9795       return -1;
9796     }
9797   }
9798   else {
9799     /* Just get the current time in VMS format directly */
9800     retsts = sys$gettim(bintime);
9801     if (!(retsts & 1)) {
9802       set_errno(EVMSERR);
9803       set_vaxc_errno(retsts);
9804       return -1;
9805     }
9806   }
9807
9808   myfab.fab$l_fna = vmsspec;
9809   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9810   myfab.fab$l_nam = &mynam;
9811   mynam.nam$l_esa = esa;
9812   mynam.nam$b_ess = (unsigned char) sizeof esa;
9813   mynam.nam$l_rsa = rsa;
9814   mynam.nam$b_rss = (unsigned char) sizeof rsa;
9815   if (decc_efs_case_preserve)
9816       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9817
9818   /* Look for the file to be affected, letting RMS parse the file
9819    * specification for us as well.  I have set errno using only
9820    * values documented in the utime() man page for VMS POSIX.
9821    */
9822   retsts = sys$parse(&myfab,0,0);
9823   if (!(retsts & 1)) {
9824     set_vaxc_errno(retsts);
9825     if      (retsts == RMS$_PRV) set_errno(EACCES);
9826     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9827     else                         set_errno(EVMSERR);
9828     return -1;
9829   }
9830   retsts = sys$search(&myfab,0,0);
9831   if (!(retsts & 1)) {
9832     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9833     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9834     set_vaxc_errno(retsts);
9835     if      (retsts == RMS$_PRV) set_errno(EACCES);
9836     else if (retsts == RMS$_FNF) set_errno(ENOENT);
9837     else                         set_errno(EVMSERR);
9838     return -1;
9839   }
9840
9841   devdsc.dsc$w_length = mynam.nam$b_dev;
9842   /* cast ok for read only parameter */
9843   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9844
9845   retsts = sys$assign(&devdsc,&chan,0,0);
9846   if (!(retsts & 1)) {
9847     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9848     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9849     set_vaxc_errno(retsts);
9850     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
9851     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
9852     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
9853     else                               set_errno(EVMSERR);
9854     return -1;
9855   }
9856
9857   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9858   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9859
9860   memset((void *) &myfib, 0, sizeof myfib);
9861 #if defined(__DECC) || defined(__DECCXX)
9862   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9863   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9864   /* This prevents the revision time of the file being reset to the current
9865    * time as a result of our IO$_MODIFY $QIO. */
9866   myfib.fib$l_acctl = FIB$M_NORECORD;
9867 #else
9868   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9869   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9870   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9871 #endif
9872   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9873   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9874   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9875   _ckvmssts(sys$dassgn(chan));
9876   if (retsts & 1) retsts = iosb[0];
9877   if (!(retsts & 1)) {
9878     set_vaxc_errno(retsts);
9879     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9880     else                      set_errno(EVMSERR);
9881     return -1;
9882   }
9883
9884   return 0;
9885 }  /* end of my_utime() */
9886 /*}}}*/
9887
9888 /*
9889  * flex_stat, flex_lstat, flex_fstat
9890  * basic stat, but gets it right when asked to stat
9891  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9892  */
9893
9894 #ifndef _USE_STD_STAT
9895 /* encode_dev packs a VMS device name string into an integer to allow
9896  * simple comparisons. This can be used, for example, to check whether two
9897  * files are located on the same device, by comparing their encoded device
9898  * names. Even a string comparison would not do, because stat() reuses the
9899  * device name buffer for each call; so without encode_dev, it would be
9900  * necessary to save the buffer and use strcmp (this would mean a number of
9901  * changes to the standard Perl code, to say nothing of what a Perl script
9902  * would have to do.
9903  *
9904  * The device lock id, if it exists, should be unique (unless perhaps compared
9905  * with lock ids transferred from other nodes). We have a lock id if the disk is
9906  * mounted cluster-wide, which is when we tend to get long (host-qualified)
9907  * device names. Thus we use the lock id in preference, and only if that isn't
9908  * available, do we try to pack the device name into an integer (flagged by
9909  * the sign bit (LOCKID_MASK) being set).
9910  *
9911  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9912  * name and its encoded form, but it seems very unlikely that we will find
9913  * two files on different disks that share the same encoded device names,
9914  * and even more remote that they will share the same file id (if the test
9915  * is to check for the same file).
9916  *
9917  * A better method might be to use sys$device_scan on the first call, and to
9918  * search for the device, returning an index into the cached array.
9919  * The number returned would be more intelligable.
9920  * This is probably not worth it, and anyway would take quite a bit longer
9921  * on the first call.
9922  */
9923 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
9924 static mydev_t encode_dev (pTHX_ const char *dev)
9925 {
9926   int i;
9927   unsigned long int f;
9928   mydev_t enc;
9929   char c;
9930   const char *q;
9931
9932   if (!dev || !dev[0]) return 0;
9933
9934 #if LOCKID_MASK
9935   {
9936     struct dsc$descriptor_s dev_desc;
9937     unsigned long int status, lockid, item = DVI$_LOCKID;
9938
9939     /* For cluster-mounted disks, the disk lock identifier is unique, so we
9940        can try that first. */
9941     dev_desc.dsc$w_length =  strlen (dev);
9942     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
9943     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
9944     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
9945     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9946     if (lockid) return (lockid & ~LOCKID_MASK);
9947   }
9948 #endif
9949
9950   /* Otherwise we try to encode the device name */
9951   enc = 0;
9952   f = 1;
9953   i = 0;
9954   for (q = dev + strlen(dev); q--; q >= dev) {
9955     if (isdigit (*q))
9956       c= (*q) - '0';
9957     else if (isalpha (toupper (*q)))
9958       c= toupper (*q) - 'A' + (char)10;
9959     else
9960       continue; /* Skip '$'s */
9961     i++;
9962     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
9963     if (i>1) f *= 36;
9964     enc += f * (unsigned long int) c;
9965   }
9966   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
9967
9968 }  /* end of encode_dev() */
9969 #endif
9970
9971 static char namecache[NAM$C_MAXRSS+1];
9972
9973 static int
9974 is_null_device(name)
9975     const char *name;
9976 {
9977   if (decc_bug_devnull != 0) {
9978     if (strncmp("/dev/null", name, 9) == 0)
9979       return 1;
9980   }
9981     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9982        The underscore prefix, controller letter, and unit number are
9983        independently optional; for our purposes, the colon punctuation
9984        is not.  The colon can be trailed by optional directory and/or
9985        filename, but two consecutive colons indicates a nodename rather
9986        than a device.  [pr]  */
9987   if (*name == '_') ++name;
9988   if (tolower(*name++) != 'n') return 0;
9989   if (tolower(*name++) != 'l') return 0;
9990   if (tolower(*name) == 'a') ++name;
9991   if (*name == '0') ++name;
9992   return (*name++ == ':') && (*name != ':');
9993 }
9994
9995 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
9996 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9997  * subset of the applicable information.
9998  */
9999 bool
10000 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
10001 {
10002   char fname_phdev[NAM$C_MAXRSS+1];
10003 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10004   /* Namecache not workable with symbolic links, as symbolic links do
10005    *  not have extensions and directories do in VMS mode.  So in order
10006    *  to test this, the did and ino_t must be used.
10007    *
10008    * Fix-me - Hide the information in the new stat structure
10009    *          Get rid of the namecache.
10010    */
10011   if (decc_posix_compliant_pathnames == 0)
10012 #endif
10013       if (statbufp == &PL_statcache)
10014           return cando_by_name(bit,effective,namecache);
10015   {
10016     char fname[NAM$C_MAXRSS+1];
10017     unsigned long int retsts;
10018     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10019                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10020
10021     /* If the struct mystat is stale, we're OOL; stat() overwrites the
10022        device name on successive calls */
10023     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
10024     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
10025     namdsc.dsc$a_pointer = fname;
10026     namdsc.dsc$w_length = sizeof fname - 1;
10027
10028     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
10029                              &namdsc,&namdsc.dsc$w_length,0,0);
10030     if (retsts & 1) {
10031       fname[namdsc.dsc$w_length] = '\0';
10032 /*
10033  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
10034  * but if someone has redefined that logical, Perl gets very lost.  Since
10035  * we have the physical device name from the stat buffer, just paste it on.
10036  */
10037       strcpy( fname_phdev, statbufp->st_devnam );
10038       strcat( fname_phdev, strrchr(fname, ':') );
10039
10040       return cando_by_name(bit,effective,fname_phdev);
10041     }
10042     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
10043       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
10044       return FALSE;
10045     }
10046     _ckvmssts(retsts);
10047     return FALSE;  /* Should never get to here */
10048   }
10049 }  /* end of cando() */
10050 /*}}}*/
10051
10052
10053 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10054 I32
10055 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10056 {
10057   static char usrname[L_cuserid];
10058   static struct dsc$descriptor_s usrdsc =
10059          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10060   char vmsname[NAM$C_MAXRSS+1];
10061   char *fileified;
10062   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
10063   unsigned short int retlen, trnlnm_iter_count;
10064   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10065   union prvdef curprv;
10066   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10067          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
10068   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10069          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10070          {0,0,0,0}};
10071   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10072          {0,0,0,0}};
10073   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10074
10075   if (!fname || !*fname) return FALSE;
10076   /* Make sure we expand logical names, since sys$check_access doesn't */
10077   fileified = PerlMem_malloc(VMS_MAXRSS);
10078   if (!strpbrk(fname,"/]>:")) {
10079     strcpy(fileified,fname);
10080     trnlnm_iter_count = 0;
10081     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10082         trnlnm_iter_count++;
10083         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10084     }
10085     fname = fileified;
10086   }
10087   if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS)) {
10088     PerlMem_free(fileified);
10089     return FALSE;
10090   }
10091   retlen = namdsc.dsc$w_length = strlen(vmsname);
10092   namdsc.dsc$a_pointer = vmsname;
10093   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10094       vmsname[retlen-1] == ':') {
10095     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
10096     namdsc.dsc$w_length = strlen(fileified);
10097     namdsc.dsc$a_pointer = fileified;
10098   }
10099
10100   switch (bit) {
10101     case S_IXUSR: case S_IXGRP: case S_IXOTH:
10102       access = ARM$M_EXECUTE; break;
10103     case S_IRUSR: case S_IRGRP: case S_IROTH:
10104       access = ARM$M_READ; break;
10105     case S_IWUSR: case S_IWGRP: case S_IWOTH:
10106       access = ARM$M_WRITE; break;
10107     case S_IDUSR: case S_IDGRP: case S_IDOTH:
10108       access = ARM$M_DELETE; break;
10109     default:
10110       PerlMem_free(fileified);
10111       return FALSE;
10112   }
10113
10114   /* Before we call $check_access, create a user profile with the current
10115    * process privs since otherwise it just uses the default privs from the
10116    * UAF and might give false positives or negatives.  This only works on
10117    * VMS versions v6.0 and later since that's when sys$create_user_profile
10118    * became available.
10119    */
10120
10121   /* get current process privs and username */
10122   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10123   _ckvmssts(iosb[0]);
10124
10125 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10126
10127   /* find out the space required for the profile */
10128   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10129                                     &usrprodsc.dsc$w_length,0));
10130
10131   /* allocate space for the profile and get it filled in */
10132   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10133   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10134   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10135                                     &usrprodsc.dsc$w_length,0));
10136
10137   /* use the profile to check access to the file; free profile & analyze results */
10138   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10139   PerlMem_free(usrprodsc.dsc$a_pointer);
10140   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10141
10142 #else
10143
10144   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10145
10146 #endif
10147
10148   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
10149       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10150       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10151     set_vaxc_errno(retsts);
10152     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10153     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10154     else set_errno(ENOENT);
10155     PerlMem_free(fileified);
10156     return FALSE;
10157   }
10158   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10159     PerlMem_free(fileified);
10160     return TRUE;
10161   }
10162   _ckvmssts(retsts);
10163
10164   PerlMem_free(fileified);
10165   return FALSE;  /* Should never get here */
10166
10167 }  /* end of cando_by_name() */
10168 /*}}}*/
10169
10170
10171 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10172 int
10173 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10174 {
10175   if (!fstat(fd,(stat_t *) statbufp)) {
10176     if (statbufp == (Stat_t *) &PL_statcache) {
10177     char *cptr;
10178
10179         /* Save name for cando by name in VMS format */
10180         cptr = getname(fd, namecache, 1);
10181
10182         /* This should not happen, but just in case */
10183         if (cptr == NULL)
10184            namecache[0] = '\0';
10185     }
10186
10187     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10188 #ifndef _USE_STD_STAT
10189     strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
10190     statbufp->st_devnam[63] = 0;
10191     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
10192 #else
10193     /* todo:
10194      * The device is only encoded so that Perl_cando can use it to
10195      * look up ACLS.  So rmsexpand it to the 255 character version
10196      * and store it in ->st_devnam.  rmsexpand needs to be fixed
10197      * for long filenames and symbolic links first.  This also seems
10198      * to remove the need for a namecache that could be stale.
10199      */
10200 #endif
10201
10202 #   ifdef RTL_USES_UTC
10203 #   ifdef VMSISH_TIME
10204     if (VMSISH_TIME) {
10205       statbufp->st_mtime = _toloc(statbufp->st_mtime);
10206       statbufp->st_atime = _toloc(statbufp->st_atime);
10207       statbufp->st_ctime = _toloc(statbufp->st_ctime);
10208     }
10209 #   endif
10210 #   else
10211 #   ifdef VMSISH_TIME
10212     if (!VMSISH_TIME) { /* Return UTC instead of local time */
10213 #   else
10214     if (1) {
10215 #   endif
10216       statbufp->st_mtime = _toutc(statbufp->st_mtime);
10217       statbufp->st_atime = _toutc(statbufp->st_atime);
10218       statbufp->st_ctime = _toutc(statbufp->st_ctime);
10219     }
10220 #endif
10221     return 0;
10222   }
10223   return -1;
10224
10225 }  /* end of flex_fstat() */
10226 /*}}}*/
10227
10228 #if !defined(__VAX) && __CRTL_VER >= 80200000
10229 #ifdef lstat
10230 #undef lstat
10231 #endif
10232 #else
10233 #ifdef lstat
10234 #undef lstat
10235 #endif
10236 #define lstat(_x, _y) stat(_x, _y)
10237 #endif
10238
10239 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
10240
10241 static int
10242 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10243 {
10244     char fileified[NAM$C_MAXRSS+1];
10245     char temp_fspec[NAM$C_MAXRSS+300];
10246     int retval = -1;
10247     int saved_errno, saved_vaxc_errno;
10248
10249     if (!fspec) return retval;
10250     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10251     strcpy(temp_fspec, fspec);
10252     if (statbufp == (Stat_t *) &PL_statcache)
10253       do_tovmsspec(temp_fspec,namecache,0);
10254     if (decc_bug_devnull != 0) {
10255       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10256         memset(statbufp,0,sizeof *statbufp);
10257         statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
10258         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10259         statbufp->st_uid = 0x00010001;
10260         statbufp->st_gid = 0x0001;
10261         time((time_t *)&statbufp->st_mtime);
10262         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10263         return 0;
10264       }
10265     }
10266
10267     /* Try for a directory name first.  If fspec contains a filename without
10268      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10269      * and sea:[wine.dark]water. exist, we prefer the directory here.
10270      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10271      * not sea:[wine.dark]., if the latter exists.  If the intended target is
10272      * the file with null type, specify this by calling flex_stat() with
10273      * a '.' at the end of fspec.
10274      *
10275      * If we are in Posix filespec mode, accept the filename as is.
10276      */
10277 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10278   if (decc_posix_compliant_pathnames == 0) {
10279 #endif
10280     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
10281       if (lstat_flag == 0)
10282         retval = stat(fileified,(stat_t *) statbufp);
10283       else
10284         retval = lstat(fileified,(stat_t *) statbufp);
10285       if (!retval && statbufp == (Stat_t *) &PL_statcache)
10286         strcpy(namecache,fileified);
10287     }
10288     if (retval) {
10289       if (lstat_flag == 0)
10290         retval = stat(temp_fspec,(stat_t *) statbufp);
10291       else
10292         retval = lstat(temp_fspec,(stat_t *) statbufp);
10293     }
10294 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10295   } else {
10296     if (lstat_flag == 0)
10297       retval = stat(temp_fspec,(stat_t *) statbufp);
10298     else
10299       retval = lstat(temp_fspec,(stat_t *) statbufp);
10300   }
10301 #endif
10302     if (!retval) {
10303       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10304 #ifndef _USE_STD_STAT
10305       strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
10306       statbufp->st_devnam[63] = 0;
10307       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
10308 #else
10309     /* todo:
10310      * The device is only encoded so that Perl_cando can use it to
10311      * look up ACLS.  So rmsexpand it to the 255 character version
10312      * and store it in ->st_devnam.  rmsexpand needs to be fixed
10313      * for long filenames and symbolic links first.  This also seems
10314      * to remove the need for a namecache that could be stale.
10315      */
10316 #endif
10317 #     ifdef RTL_USES_UTC
10318 #     ifdef VMSISH_TIME
10319       if (VMSISH_TIME) {
10320         statbufp->st_mtime = _toloc(statbufp->st_mtime);
10321         statbufp->st_atime = _toloc(statbufp->st_atime);
10322         statbufp->st_ctime = _toloc(statbufp->st_ctime);
10323       }
10324 #     endif
10325 #     else
10326 #     ifdef VMSISH_TIME
10327       if (!VMSISH_TIME) { /* Return UTC instead of local time */
10328 #     else
10329       if (1) {
10330 #     endif
10331         statbufp->st_mtime = _toutc(statbufp->st_mtime);
10332         statbufp->st_atime = _toutc(statbufp->st_atime);
10333         statbufp->st_ctime = _toutc(statbufp->st_ctime);
10334       }
10335 #     endif
10336     }
10337     /* If we were successful, leave errno where we found it */
10338     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10339     return retval;
10340
10341 }  /* end of flex_stat_int() */
10342
10343
10344 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10345 int
10346 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10347 {
10348    return flex_stat_int(fspec, statbufp, 0);
10349 }
10350 /*}}}*/
10351
10352 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10353 int
10354 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10355 {
10356    return flex_stat_int(fspec, statbufp, 1);
10357 }
10358 /*}}}*/
10359
10360
10361 /*{{{char *my_getlogin()*/
10362 /* VMS cuserid == Unix getlogin, except calling sequence */
10363 char *
10364 my_getlogin(void)
10365 {
10366     static char user[L_cuserid];
10367     return cuserid(user);
10368 }
10369 /*}}}*/
10370
10371
10372 /*  rmscopy - copy a file using VMS RMS routines
10373  *
10374  *  Copies contents and attributes of spec_in to spec_out, except owner
10375  *  and protection information.  Name and type of spec_in are used as
10376  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
10377  *  should try to propagate timestamps from the input file to the output file.
10378  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
10379  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
10380  *  propagated to the output file at creation iff the output file specification
10381  *  did not contain an explicit name or type, and the revision date is always
10382  *  updated at the end of the copy operation.  If it is greater than 0, then
10383  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
10384  *  other than the revision date should be propagated, and bit 1 indicates
10385  *  that the revision date should be propagated.
10386  *
10387  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
10388  *
10389  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
10390  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
10391  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
10392  * as part of the Perl standard distribution under the terms of the
10393  * GNU General Public License or the Perl Artistic License.  Copies
10394  * of each may be found in the Perl standard distribution.
10395  */ /* FIXME */
10396 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
10397 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
10398 int
10399 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10400 {
10401     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
10402          rsa[NAM$C_MAXRSS], ubf[32256];
10403     unsigned long int i, sts, sts2;
10404     struct FAB fab_in, fab_out;
10405     struct RAB rab_in, rab_out;
10406     struct NAM nam;
10407     struct XABDAT xabdat;
10408     struct XABFHC xabfhc;
10409     struct XABRDT xabrdt;
10410     struct XABSUM xabsum;
10411
10412     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
10413         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10414       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10415       return 0;
10416     }
10417
10418     fab_in = cc$rms_fab;
10419     fab_in.fab$l_fna = vmsin;
10420     fab_in.fab$b_fns = strlen(vmsin);
10421     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10422     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10423     fab_in.fab$l_fop = FAB$M_SQO;
10424     fab_in.fab$l_nam =  &nam;
10425     fab_in.fab$l_xab = (void *) &xabdat;
10426
10427     nam = cc$rms_nam;
10428     nam.nam$l_rsa = rsa;
10429     nam.nam$b_rss = sizeof(rsa);
10430     nam.nam$l_esa = esa;
10431     nam.nam$b_ess = sizeof (esa);
10432     nam.nam$b_esl = nam.nam$b_rsl = 0;
10433 #ifdef NAM$M_NO_SHORT_UPCASE
10434     if (decc_efs_case_preserve)
10435         nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10436 #endif
10437
10438     xabdat = cc$rms_xabdat;        /* To get creation date */
10439     xabdat.xab$l_nxt = (void *) &xabfhc;
10440
10441     xabfhc = cc$rms_xabfhc;        /* To get record length */
10442     xabfhc.xab$l_nxt = (void *) &xabsum;
10443
10444     xabsum = cc$rms_xabsum;        /* To get key and area information */
10445
10446     if (!((sts = sys$open(&fab_in)) & 1)) {
10447       set_vaxc_errno(sts);
10448       switch (sts) {
10449         case RMS$_FNF: case RMS$_DNF:
10450           set_errno(ENOENT); break;
10451         case RMS$_DIR:
10452           set_errno(ENOTDIR); break;
10453         case RMS$_DEV:
10454           set_errno(ENODEV); break;
10455         case RMS$_SYN:
10456           set_errno(EINVAL); break;
10457         case RMS$_PRV:
10458           set_errno(EACCES); break;
10459         default:
10460           set_errno(EVMSERR);
10461       }
10462       return 0;
10463     }
10464
10465     fab_out = fab_in;
10466     fab_out.fab$w_ifi = 0;
10467     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10468     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10469     fab_out.fab$l_fop = FAB$M_SQO;
10470     fab_out.fab$l_fna = vmsout;
10471     fab_out.fab$b_fns = strlen(vmsout);
10472     fab_out.fab$l_dna = nam.nam$l_name;
10473     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
10474
10475     if (preserve_dates == 0) {  /* Act like DCL COPY */
10476       nam.nam$b_nop |= NAM$M_SYNCHK;
10477       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10478       if (!((sts = sys$parse(&fab_out)) & 1)) {
10479         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10480         set_vaxc_errno(sts);
10481         return 0;
10482       }
10483       fab_out.fab$l_xab = (void *) &xabdat;
10484       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10485     }
10486     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
10487     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10488       preserve_dates =0;      /* bitmask from this point forward   */
10489
10490     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10491     if (!((sts = sys$create(&fab_out)) & 1)) {
10492       set_vaxc_errno(sts);
10493       switch (sts) {
10494         case RMS$_DNF:
10495           set_errno(ENOENT); break;
10496         case RMS$_DIR:
10497           set_errno(ENOTDIR); break;
10498         case RMS$_DEV:
10499           set_errno(ENODEV); break;
10500         case RMS$_SYN:
10501           set_errno(EINVAL); break;
10502         case RMS$_PRV:
10503           set_errno(EACCES); break;
10504         default:
10505           set_errno(EVMSERR);
10506       }
10507       return 0;
10508     }
10509     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10510     if (preserve_dates & 2) {
10511       /* sys$close() will process xabrdt, not xabdat */
10512       xabrdt = cc$rms_xabrdt;
10513 #ifndef __GNUC__
10514       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10515 #else
10516       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10517        * is unsigned long[2], while DECC & VAXC use a struct */
10518       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10519 #endif
10520       fab_out.fab$l_xab = (void *) &xabrdt;
10521     }
10522
10523     rab_in = cc$rms_rab;
10524     rab_in.rab$l_fab = &fab_in;
10525     rab_in.rab$l_rop = RAB$M_BIO;
10526     rab_in.rab$l_ubf = ubf;
10527     rab_in.rab$w_usz = sizeof ubf;
10528     if (!((sts = sys$connect(&rab_in)) & 1)) {
10529       sys$close(&fab_in); sys$close(&fab_out);
10530       set_errno(EVMSERR); set_vaxc_errno(sts);
10531       return 0;
10532     }
10533
10534     rab_out = cc$rms_rab;
10535     rab_out.rab$l_fab = &fab_out;
10536     rab_out.rab$l_rbf = ubf;
10537     if (!((sts = sys$connect(&rab_out)) & 1)) {
10538       sys$close(&fab_in); sys$close(&fab_out);
10539       set_errno(EVMSERR); set_vaxc_errno(sts);
10540       return 0;
10541     }
10542
10543     while ((sts = sys$read(&rab_in))) {  /* always true  */
10544       if (sts == RMS$_EOF) break;
10545       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10546       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10547         sys$close(&fab_in); sys$close(&fab_out);
10548         set_errno(EVMSERR); set_vaxc_errno(sts);
10549         return 0;
10550       }
10551     }
10552
10553     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10554     sys$close(&fab_in);  sys$close(&fab_out);
10555     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10556     if (!(sts & 1)) {
10557       set_errno(EVMSERR); set_vaxc_errno(sts);
10558       return 0;
10559     }
10560
10561     return 1;
10562
10563 }  /* end of rmscopy() */
10564 #else
10565 /* ODS-5 support version */
10566 int
10567 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10568 {
10569     char *vmsin, * vmsout, *esa, *esa_out,
10570          *rsa, *ubf;
10571     unsigned long int i, sts, sts2;
10572     struct FAB fab_in, fab_out;
10573     struct RAB rab_in, rab_out;
10574     struct NAML nam;
10575     struct NAML nam_out;
10576     struct XABDAT xabdat;
10577     struct XABFHC xabfhc;
10578     struct XABRDT xabrdt;
10579     struct XABSUM xabsum;
10580
10581     vmsin = PerlMem_malloc(VMS_MAXRSS);
10582     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
10583     vmsout = PerlMem_malloc(VMS_MAXRSS);
10584     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
10585     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
10586         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10587       PerlMem_free(vmsin);
10588       PerlMem_free(vmsout);
10589       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10590       return 0;
10591     }
10592
10593     esa = PerlMem_malloc(VMS_MAXRSS);
10594     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
10595     nam = cc$rms_naml;
10596     fab_in = cc$rms_fab;
10597     fab_in.fab$l_fna = (char *) -1;
10598     fab_in.fab$b_fns = 0;
10599     nam.naml$l_long_filename = vmsin;
10600     nam.naml$l_long_filename_size = strlen(vmsin);
10601     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10602     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10603     fab_in.fab$l_fop = FAB$M_SQO;
10604     fab_in.fab$l_naml =  &nam;
10605     fab_in.fab$l_xab = (void *) &xabdat;
10606
10607     rsa = PerlMem_malloc(VMS_MAXRSS);
10608     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
10609     nam.naml$l_rsa = NULL;
10610     nam.naml$b_rss = 0;
10611     nam.naml$l_long_result = rsa;
10612     nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10613     nam.naml$l_esa = NULL;
10614     nam.naml$b_ess = 0;
10615     nam.naml$l_long_expand = esa;
10616     nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10617     nam.naml$b_esl = nam.naml$b_rsl = 0;
10618     nam.naml$l_long_expand_size = 0;
10619     nam.naml$l_long_result_size = 0;
10620 #ifdef NAM$M_NO_SHORT_UPCASE
10621     if (decc_efs_case_preserve)
10622         nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10623 #endif
10624
10625     xabdat = cc$rms_xabdat;        /* To get creation date */
10626     xabdat.xab$l_nxt = (void *) &xabfhc;
10627
10628     xabfhc = cc$rms_xabfhc;        /* To get record length */
10629     xabfhc.xab$l_nxt = (void *) &xabsum;
10630
10631     xabsum = cc$rms_xabsum;        /* To get key and area information */
10632
10633     if (!((sts = sys$open(&fab_in)) & 1)) {
10634       PerlMem_free(vmsin);
10635       PerlMem_free(vmsout);
10636       PerlMem_free(esa);
10637       PerlMem_free(rsa);
10638       set_vaxc_errno(sts);
10639       switch (sts) {
10640         case RMS$_FNF: case RMS$_DNF:
10641           set_errno(ENOENT); break;
10642         case RMS$_DIR:
10643           set_errno(ENOTDIR); break;
10644         case RMS$_DEV:
10645           set_errno(ENODEV); break;
10646         case RMS$_SYN:
10647           set_errno(EINVAL); break;
10648         case RMS$_PRV:
10649           set_errno(EACCES); break;
10650         default:
10651           set_errno(EVMSERR);
10652       }
10653       return 0;
10654     }
10655
10656     nam_out = nam;
10657     fab_out = fab_in;
10658     fab_out.fab$w_ifi = 0;
10659     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10660     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10661     fab_out.fab$l_fop = FAB$M_SQO;
10662     fab_out.fab$l_naml = &nam_out;
10663     fab_out.fab$l_fna = (char *) -1;
10664     fab_out.fab$b_fns = 0;
10665     nam_out.naml$l_long_filename = vmsout;
10666     nam_out.naml$l_long_filename_size = strlen(vmsout);
10667     fab_out.fab$l_dna = (char *) -1;
10668     fab_out.fab$b_dns = 0;
10669     nam_out.naml$l_long_defname = nam.naml$l_long_name;
10670     nam_out.naml$l_long_defname_size =
10671         nam.naml$l_long_name ?
10672            nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10673
10674     esa_out = PerlMem_malloc(VMS_MAXRSS);
10675     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
10676     nam_out.naml$l_rsa = NULL;
10677     nam_out.naml$b_rss = 0;
10678     nam_out.naml$l_long_result = NULL;
10679     nam_out.naml$l_long_result_alloc = 0;
10680     nam_out.naml$l_esa = NULL;
10681     nam_out.naml$b_ess = 0;
10682     nam_out.naml$l_long_expand = esa_out;
10683     nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10684
10685     if (preserve_dates == 0) {  /* Act like DCL COPY */
10686       nam_out.naml$b_nop |= NAM$M_SYNCHK;
10687       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10688       if (!((sts = sys$parse(&fab_out)) & 1)) {
10689         PerlMem_free(vmsin);
10690         PerlMem_free(vmsout);
10691         PerlMem_free(esa);
10692         PerlMem_free(rsa);
10693         PerlMem_free(esa_out);
10694         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10695         set_vaxc_errno(sts);
10696         return 0;
10697       }
10698       fab_out.fab$l_xab = (void *) &xabdat;
10699       if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10700     }
10701     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10702       preserve_dates =0;      /* bitmask from this point forward   */
10703
10704     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10705     if (!((sts = sys$create(&fab_out)) & 1)) {
10706       PerlMem_free(vmsin);
10707       PerlMem_free(vmsout);
10708       PerlMem_free(esa);
10709       PerlMem_free(rsa);
10710       PerlMem_free(esa_out);
10711       set_vaxc_errno(sts);
10712       switch (sts) {
10713         case RMS$_DNF:
10714           set_errno(ENOENT); break;
10715         case RMS$_DIR:
10716           set_errno(ENOTDIR); break;
10717         case RMS$_DEV:
10718           set_errno(ENODEV); break;
10719         case RMS$_SYN:
10720           set_errno(EINVAL); break;
10721         case RMS$_PRV:
10722           set_errno(EACCES); break;
10723         default:
10724           set_errno(EVMSERR);
10725       }
10726       return 0;
10727     }
10728     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10729     if (preserve_dates & 2) {
10730       /* sys$close() will process xabrdt, not xabdat */
10731       xabrdt = cc$rms_xabrdt;
10732 #ifndef __GNUC__
10733       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10734 #else
10735       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10736        * is unsigned long[2], while DECC & VAXC use a struct */
10737       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10738 #endif
10739       fab_out.fab$l_xab = (void *) &xabrdt;
10740     }
10741
10742     ubf = PerlMem_malloc(32256);
10743     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
10744     rab_in = cc$rms_rab;
10745     rab_in.rab$l_fab = &fab_in;
10746     rab_in.rab$l_rop = RAB$M_BIO;
10747     rab_in.rab$l_ubf = ubf;
10748     rab_in.rab$w_usz = 32256;
10749     if (!((sts = sys$connect(&rab_in)) & 1)) {
10750       sys$close(&fab_in); sys$close(&fab_out);
10751       PerlMem_free(vmsin);
10752       PerlMem_free(vmsout);
10753       PerlMem_free(esa);
10754       PerlMem_free(ubf);
10755       PerlMem_free(rsa);
10756       PerlMem_free(esa_out);
10757       set_errno(EVMSERR); set_vaxc_errno(sts);
10758       return 0;
10759     }
10760
10761     rab_out = cc$rms_rab;
10762     rab_out.rab$l_fab = &fab_out;
10763     rab_out.rab$l_rbf = ubf;
10764     if (!((sts = sys$connect(&rab_out)) & 1)) {
10765       sys$close(&fab_in); sys$close(&fab_out);
10766       PerlMem_free(vmsin);
10767       PerlMem_free(vmsout);
10768       PerlMem_free(esa);
10769       PerlMem_free(ubf);
10770       PerlMem_free(rsa);
10771       PerlMem_free(esa_out);
10772       set_errno(EVMSERR); set_vaxc_errno(sts);
10773       return 0;
10774     }
10775
10776     while ((sts = sys$read(&rab_in))) {  /* always true  */
10777       if (sts == RMS$_EOF) break;
10778       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10779       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10780         sys$close(&fab_in); sys$close(&fab_out);
10781         PerlMem_free(vmsin);
10782         PerlMem_free(vmsout);
10783         PerlMem_free(esa);
10784         PerlMem_free(ubf);
10785         PerlMem_free(rsa);
10786         PerlMem_free(esa_out);
10787         set_errno(EVMSERR); set_vaxc_errno(sts);
10788         return 0;
10789       }
10790     }
10791
10792
10793     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10794     sys$close(&fab_in);  sys$close(&fab_out);
10795     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10796     if (!(sts & 1)) {
10797       PerlMem_free(vmsin);
10798       PerlMem_free(vmsout);
10799       PerlMem_free(esa);
10800       PerlMem_free(ubf);
10801       PerlMem_free(rsa);
10802       PerlMem_free(esa_out);
10803       set_errno(EVMSERR); set_vaxc_errno(sts);
10804       return 0;
10805     }
10806
10807     PerlMem_free(vmsin);
10808     PerlMem_free(vmsout);
10809     PerlMem_free(esa);
10810     PerlMem_free(ubf);
10811     PerlMem_free(rsa);
10812     PerlMem_free(esa_out);
10813     return 1;
10814
10815 }  /* end of rmscopy() */
10816 #endif
10817 /*}}}*/
10818
10819
10820 /***  The following glue provides 'hooks' to make some of the routines
10821  * from this file available from Perl.  These routines are sufficiently
10822  * basic, and are required sufficiently early in the build process,
10823  * that's it's nice to have them available to miniperl as well as the
10824  * full Perl, so they're set up here instead of in an extension.  The
10825  * Perl code which handles importation of these names into a given
10826  * package lives in [.VMS]Filespec.pm in @INC.
10827  */
10828
10829 void
10830 rmsexpand_fromperl(pTHX_ CV *cv)
10831 {
10832   dXSARGS;
10833   char *fspec, *defspec = NULL, *rslt;
10834   STRLEN n_a;
10835
10836   if (!items || items > 2)
10837     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10838   fspec = SvPV(ST(0),n_a);
10839   if (!fspec || !*fspec) XSRETURN_UNDEF;
10840   if (items == 2) defspec = SvPV(ST(1),n_a);
10841
10842   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10843   ST(0) = sv_newmortal();
10844   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10845   XSRETURN(1);
10846 }
10847
10848 void
10849 vmsify_fromperl(pTHX_ CV *cv)
10850 {
10851   dXSARGS;
10852   char *vmsified;
10853   STRLEN n_a;
10854
10855   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10856   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10857   ST(0) = sv_newmortal();
10858   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10859   XSRETURN(1);
10860 }
10861
10862 void
10863 unixify_fromperl(pTHX_ CV *cv)
10864 {
10865   dXSARGS;
10866   char *unixified;
10867   STRLEN n_a;
10868
10869   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10870   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10871   ST(0) = sv_newmortal();
10872   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10873   XSRETURN(1);
10874 }
10875
10876 void
10877 fileify_fromperl(pTHX_ CV *cv)
10878 {
10879   dXSARGS;
10880   char *fileified;
10881   STRLEN n_a;
10882
10883   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10884   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10885   ST(0) = sv_newmortal();
10886   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10887   XSRETURN(1);
10888 }
10889
10890 void
10891 pathify_fromperl(pTHX_ CV *cv)
10892 {
10893   dXSARGS;
10894   char *pathified;
10895   STRLEN n_a;
10896
10897   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10898   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10899   ST(0) = sv_newmortal();
10900   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10901   XSRETURN(1);
10902 }
10903
10904 void
10905 vmspath_fromperl(pTHX_ CV *cv)
10906 {
10907   dXSARGS;
10908   char *vmspath;
10909   STRLEN n_a;
10910
10911   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10912   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10913   ST(0) = sv_newmortal();
10914   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10915   XSRETURN(1);
10916 }
10917
10918 void
10919 unixpath_fromperl(pTHX_ CV *cv)
10920 {
10921   dXSARGS;
10922   char *unixpath;
10923   STRLEN n_a;
10924
10925   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10926   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10927   ST(0) = sv_newmortal();
10928   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10929   XSRETURN(1);
10930 }
10931
10932 void
10933 candelete_fromperl(pTHX_ CV *cv)
10934 {
10935   dXSARGS;
10936   char fspec[NAM$C_MAXRSS+1], *fsp;
10937   SV *mysv;
10938   IO *io;
10939   STRLEN n_a;
10940
10941   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10942
10943   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10944   if (SvTYPE(mysv) == SVt_PVGV) {
10945     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10946       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10947       ST(0) = &PL_sv_no;
10948       XSRETURN(1);
10949     }
10950     fsp = fspec;
10951   }
10952   else {
10953     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10954       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10955       ST(0) = &PL_sv_no;
10956       XSRETURN(1);
10957     }
10958   }
10959
10960   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10961   XSRETURN(1);
10962 }
10963
10964 void
10965 rmscopy_fromperl(pTHX_ CV *cv)
10966 {
10967   dXSARGS;
10968   char *inspec, *outspec, *inp, *outp;
10969   int date_flag;
10970   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10971                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10972   unsigned long int sts;
10973   SV *mysv;
10974   IO *io;
10975   STRLEN n_a;
10976
10977   if (items < 2 || items > 3)
10978     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10979
10980   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10981   Newx(inspec, VMS_MAXRSS, char);
10982   if (SvTYPE(mysv) == SVt_PVGV) {
10983     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10984       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10985       ST(0) = &PL_sv_no;
10986       Safefree(inspec);
10987       XSRETURN(1);
10988     }
10989     inp = inspec;
10990   }
10991   else {
10992     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10993       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10994       ST(0) = &PL_sv_no;
10995       Safefree(inspec);
10996       XSRETURN(1);
10997     }
10998   }
10999   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11000   Newx(outspec, VMS_MAXRSS, char);
11001   if (SvTYPE(mysv) == SVt_PVGV) {
11002     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11003       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11004       ST(0) = &PL_sv_no;
11005       Safefree(inspec);
11006       Safefree(outspec);
11007       XSRETURN(1);
11008     }
11009     outp = outspec;
11010   }
11011   else {
11012     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11013       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11014       ST(0) = &PL_sv_no;
11015       Safefree(inspec);
11016       Safefree(outspec);
11017       XSRETURN(1);
11018     }
11019   }
11020   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11021
11022   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11023   Safefree(inspec);
11024   Safefree(outspec);
11025   XSRETURN(1);
11026 }
11027
11028 /* The mod2fname is limited to shorter filenames by design, so it should
11029  * not be modified to support longer EFS pathnames
11030  */
11031 void
11032 mod2fname(pTHX_ CV *cv)
11033 {
11034   dXSARGS;
11035   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11036        workbuff[NAM$C_MAXRSS*1 + 1];
11037   int total_namelen = 3, counter, num_entries;
11038   /* ODS-5 ups this, but we want to be consistent, so... */
11039   int max_name_len = 39;
11040   AV *in_array = (AV *)SvRV(ST(0));
11041
11042   num_entries = av_len(in_array);
11043
11044   /* All the names start with PL_. */
11045   strcpy(ultimate_name, "PL_");
11046
11047   /* Clean up our working buffer */
11048   Zero(work_name, sizeof(work_name), char);
11049
11050   /* Run through the entries and build up a working name */
11051   for(counter = 0; counter <= num_entries; counter++) {
11052     /* If it's not the first name then tack on a __ */
11053     if (counter) {
11054       strcat(work_name, "__");
11055     }
11056     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11057                            PL_na));
11058   }
11059
11060   /* Check to see if we actually have to bother...*/
11061   if (strlen(work_name) + 3 <= max_name_len) {
11062     strcat(ultimate_name, work_name);
11063   } else {
11064     /* It's too darned big, so we need to go strip. We use the same */
11065     /* algorithm as xsubpp does. First, strip out doubled __ */
11066     char *source, *dest, last;
11067     dest = workbuff;
11068     last = 0;
11069     for (source = work_name; *source; source++) {
11070       if (last == *source && last == '_') {
11071         continue;
11072       }
11073       *dest++ = *source;
11074       last = *source;
11075     }
11076     /* Go put it back */
11077     strcpy(work_name, workbuff);
11078     /* Is it still too big? */
11079     if (strlen(work_name) + 3 > max_name_len) {
11080       /* Strip duplicate letters */
11081       last = 0;
11082       dest = workbuff;
11083       for (source = work_name; *source; source++) {
11084         if (last == toupper(*source)) {
11085         continue;
11086         }
11087         *dest++ = *source;
11088         last = toupper(*source);
11089       }
11090       strcpy(work_name, workbuff);
11091     }
11092
11093     /* Is it *still* too big? */
11094     if (strlen(work_name) + 3 > max_name_len) {
11095       /* Too bad, we truncate */
11096       work_name[max_name_len - 2] = 0;
11097     }
11098     strcat(ultimate_name, work_name);
11099   }
11100
11101   /* Okay, return it */
11102   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11103   XSRETURN(1);
11104 }
11105
11106 void
11107 hushexit_fromperl(pTHX_ CV *cv)
11108 {
11109     dXSARGS;
11110
11111     if (items > 0) {
11112         VMSISH_HUSHED = SvTRUE(ST(0));
11113     }
11114     ST(0) = boolSV(VMSISH_HUSHED);
11115     XSRETURN(1);
11116 }
11117
11118
11119 PerlIO *
11120 Perl_vms_start_glob
11121    (pTHX_ SV *tmpglob,
11122     IO *io)
11123 {
11124     PerlIO *fp;
11125     struct vs_str_st *rslt;
11126     char *vmsspec;
11127     char *rstr;
11128     char *begin, *cp;
11129     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11130     PerlIO *tmpfp;
11131     STRLEN i;
11132     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11133     struct dsc$descriptor_vs rsdsc;
11134     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11135     unsigned long hasver = 0, isunix = 0;
11136     unsigned long int lff_flags = 0;
11137     int rms_sts;
11138
11139 #ifdef VMS_LONGNAME_SUPPORT
11140     lff_flags = LIB$M_FIL_LONG_NAMES;
11141 #endif
11142     /* The Newx macro will not allow me to assign a smaller array
11143      * to the rslt pointer, so we will assign it to the begin char pointer
11144      * and then copy the value into the rslt pointer.
11145      */
11146     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11147     rslt = (struct vs_str_st *)begin;
11148     rslt->length = 0;
11149     rstr = &rslt->str[0];
11150     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11151     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11152     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11153     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11154
11155     Newx(vmsspec, VMS_MAXRSS, char);
11156
11157         /* We could find out if there's an explicit dev/dir or version
11158            by peeking into lib$find_file's internal context at
11159            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11160            but that's unsupported, so I don't want to do it now and
11161            have it bite someone in the future. */
11162         /* Fix-me: vms_split_path() is the only way to do this, the
11163            existing method will fail with many legal EFS or UNIX specifications
11164          */
11165
11166     cp = SvPV(tmpglob,i);
11167
11168     for (; i; i--) {
11169         if (cp[i] == ';') hasver = 1;
11170         if (cp[i] == '.') {
11171             if (sts) hasver = 1;
11172             else sts = 1;
11173         }
11174         if (cp[i] == '/') {
11175             hasdir = isunix = 1;
11176             break;
11177         }
11178         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11179             hasdir = 1;
11180             break;
11181         }
11182     }
11183     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11184         Stat_t st;
11185         int stat_sts;
11186         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11187         if (!stat_sts && S_ISDIR(st.st_mode)) {
11188             wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec);
11189             ok = (wilddsc.dsc$a_pointer != NULL);
11190         }
11191         else {
11192             wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec);
11193             ok = (wilddsc.dsc$a_pointer != NULL);
11194         }
11195         if (ok)
11196             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11197
11198         /* If not extended character set, replace ? with % */
11199         /* With extended character set, ? is a wildcard single character */
11200         if (!decc_efs_case_preserve) {
11201             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11202                 if (*cp == '?') *cp = '%';
11203         }
11204         sts = SS$_NORMAL;
11205         while (ok && $VMS_STATUS_SUCCESS(sts)) {
11206          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11207          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11208
11209             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11210                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
11211             if (!$VMS_STATUS_SUCCESS(sts))
11212                 break;
11213
11214             /* with varying string, 1st word of buffer contains result length */
11215             rstr[rslt->length] = '\0';
11216
11217              /* Find where all the components are */
11218              v_sts = vms_split_path
11219                        (aTHX_ rstr,
11220                         &v_spec,
11221                         &v_len,
11222                         &r_spec,
11223                         &r_len,
11224                         &d_spec,
11225                         &d_len,
11226                         &n_spec,
11227                         &n_len,
11228                         &e_spec,
11229                         &e_len,
11230                         &vs_spec,
11231                         &vs_len);
11232
11233             /* If no version on input, truncate the version on output */
11234             if (!hasver && (vs_len > 0)) {
11235                 *vs_spec = '\0';
11236                 vs_len = 0;
11237
11238                 /* No version & a null extension on UNIX handling */
11239                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
11240                     e_len = 0;
11241                     *e_spec = '\0';
11242                 }
11243             }
11244
11245             if (!decc_efs_case_preserve) {
11246                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
11247             }
11248
11249             if (hasdir) {
11250                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
11251                 begin = rstr;
11252             }
11253             else {
11254                 /* Start with the name */
11255                 begin = n_spec;
11256             }
11257             strcat(begin,"\n");
11258             ok = (PerlIO_puts(tmpfp,begin) != EOF);
11259         }
11260         if (cxt) (void)lib$find_file_end(&cxt);
11261         if (ok && sts != RMS$_NMF &&
11262             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
11263         if (!ok) {
11264             if (!(sts & 1)) {
11265                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
11266             }
11267             PerlIO_close(tmpfp);
11268             fp = NULL;
11269         }
11270         else {
11271             PerlIO_rewind(tmpfp);
11272             IoTYPE(io) = IoTYPE_RDONLY;
11273             IoIFP(io) = fp = tmpfp;
11274             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
11275         }
11276     }
11277     Safefree(vmsspec);
11278     Safefree(rslt);
11279     return fp;
11280 }
11281
11282 #ifdef HAS_SYMLINK
11283 static char *
11284 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
11285
11286 void
11287 vms_realpath_fromperl(pTHX_ CV *cv)
11288 {
11289   dXSARGS;
11290   char *fspec, *rslt_spec, *rslt;
11291   STRLEN n_a;
11292
11293   if (!items || items != 1)
11294     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11295
11296   fspec = SvPV(ST(0),n_a);
11297   if (!fspec || !*fspec) XSRETURN_UNDEF;
11298
11299   Newx(rslt_spec, VMS_MAXRSS + 1, char);
11300   rslt = do_vms_realpath(fspec, rslt_spec);
11301   ST(0) = sv_newmortal();
11302   if (rslt != NULL)
11303     sv_usepvn(ST(0),rslt,strlen(rslt));
11304   else
11305     Safefree(rslt_spec);
11306   XSRETURN(1);
11307 }
11308 #endif
11309
11310 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11311 int do_vms_case_tolerant(void);
11312
11313 void
11314 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11315 {
11316   dXSARGS;
11317   ST(0) = boolSV(do_vms_case_tolerant());
11318   XSRETURN(1);
11319 }
11320 #endif
11321
11322 void
11323 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11324                           struct interp_intern *dst)
11325 {
11326     memcpy(dst,src,sizeof(struct interp_intern));
11327 }
11328
11329 void
11330 Perl_sys_intern_clear(pTHX)
11331 {
11332 }
11333
11334 void
11335 Perl_sys_intern_init(pTHX)
11336 {
11337     unsigned int ix = RAND_MAX;
11338     double x;
11339
11340     VMSISH_HUSHED = 0;
11341
11342     /* fix me later to track running under GNV */
11343     /* this allows some limited testing */
11344     MY_POSIX_EXIT = decc_filename_unix_report;
11345
11346     x = (float)ix;
11347     MY_INV_RAND_MAX = 1./x;
11348 }
11349
11350 void
11351 init_os_extras(void)
11352 {
11353   dTHX;
11354   char* file = __FILE__;
11355   char temp_buff[512];
11356   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
11357     no_translate_barewords = TRUE;
11358   } else {
11359     no_translate_barewords = FALSE;
11360   }
11361
11362   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11363   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11364   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11365   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11366   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11367   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11368   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11369   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11370   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11371   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11372   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11373 #ifdef HAS_SYMLINK
11374   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11375 #endif
11376 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11377   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11378 #endif
11379
11380   store_pipelocs(aTHX);         /* will redo any earlier attempts */
11381
11382   return;
11383 }
11384
11385 #ifdef HAS_SYMLINK
11386
11387 #if __CRTL_VER == 80200000
11388 /* This missed getting in to the DECC SDK for 8.2 */
11389 char *realpath(const char *file_name, char * resolved_name, ...);
11390 #endif
11391
11392 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11393 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11394  * The perl fallback routine to provide realpath() is not as efficient
11395  * on OpenVMS.
11396  */
11397 static char *
11398 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11399 {
11400     return realpath(filespec, outbuf);
11401 }
11402
11403 /*}}}*/
11404 /* External entry points */
11405 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11406 { return do_vms_realpath(filespec, outbuf); }
11407 #else
11408 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11409 { return NULL; }
11410 #endif
11411
11412
11413 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11414 /* case_tolerant */
11415
11416 /*{{{int do_vms_case_tolerant(void)*/
11417 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11418  * controlled by a process setting.
11419  */
11420 int do_vms_case_tolerant(void)
11421 {
11422     return vms_process_case_tolerant;
11423 }
11424 /*}}}*/
11425 /* External entry points */
11426 int Perl_vms_case_tolerant(void)
11427 { return do_vms_case_tolerant(); }
11428 #else
11429 int Perl_vms_case_tolerant(void)
11430 { return vms_process_case_tolerant; }
11431 #endif
11432
11433
11434  /* Start of DECC RTL Feature handling */
11435
11436 static int sys_trnlnm
11437    (const char * logname,
11438     char * value,
11439     int value_len)
11440 {
11441     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11442     const unsigned long attr = LNM$M_CASE_BLIND;
11443     struct dsc$descriptor_s name_dsc;
11444     int status;
11445     unsigned short result;
11446     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11447                                 {0, 0, 0, 0}};
11448
11449     name_dsc.dsc$w_length = strlen(logname);
11450     name_dsc.dsc$a_pointer = (char *)logname;
11451     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11452     name_dsc.dsc$b_class = DSC$K_CLASS_S;
11453
11454     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11455
11456     if ($VMS_STATUS_SUCCESS(status)) {
11457
11458          /* Null terminate and return the string */
11459         /*--------------------------------------*/
11460         value[result] = 0;
11461     }
11462
11463     return status;
11464 }
11465
11466 static int sys_crelnm
11467    (const char * logname,
11468     const char * value)
11469 {
11470     int ret_val;
11471     const char * proc_table = "LNM$PROCESS_TABLE";
11472     struct dsc$descriptor_s proc_table_dsc;
11473     struct dsc$descriptor_s logname_dsc;
11474     struct itmlst_3 item_list[2];
11475
11476     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11477     proc_table_dsc.dsc$w_length = strlen(proc_table);
11478     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11479     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11480
11481     logname_dsc.dsc$a_pointer = (char *) logname;
11482     logname_dsc.dsc$w_length = strlen(logname);
11483     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11484     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11485
11486     item_list[0].buflen = strlen(value);
11487     item_list[0].itmcode = LNM$_STRING;
11488     item_list[0].bufadr = (char *)value;
11489     item_list[0].retlen = NULL;
11490
11491     item_list[1].buflen = 0;
11492     item_list[1].itmcode = 0;
11493
11494     ret_val = sys$crelnm
11495                        (NULL,
11496                         (const struct dsc$descriptor_s *)&proc_table_dsc,
11497                         (const struct dsc$descriptor_s *)&logname_dsc,
11498                         NULL,
11499                         (const struct item_list_3 *) item_list);
11500
11501     return ret_val;
11502 }
11503
11504
11505 /* C RTL Feature settings */
11506
11507 static int set_features
11508    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
11509     int (* cli_routine)(void),  /* Not documented */
11510     void *image_info)           /* Not documented */
11511 {
11512     int status;
11513     int s;
11514     int dflt;
11515     char* str;
11516     char val_str[10];
11517 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11518     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
11519     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
11520     unsigned long case_perm;
11521     unsigned long case_image;
11522 #endif
11523
11524     /* Allow an exception to bring Perl into the VMS debugger */
11525     vms_debug_on_exception = 0;
11526     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
11527     if ($VMS_STATUS_SUCCESS(status)) {
11528        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11529          vms_debug_on_exception = 1;
11530        else
11531          vms_debug_on_exception = 0;
11532     }
11533
11534
11535     /* hacks to see if known bugs are still present for testing */
11536
11537     /* Readdir is returning filenames in VMS syntax always */
11538     decc_bug_readdir_efs1 = 1;
11539     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
11540     if ($VMS_STATUS_SUCCESS(status)) {
11541        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11542          decc_bug_readdir_efs1 = 1;
11543        else
11544          decc_bug_readdir_efs1 = 0;
11545     }
11546
11547     /* PCP mode requires creating /dev/null special device file */
11548     decc_bug_devnull = 0;
11549     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
11550     if ($VMS_STATUS_SUCCESS(status)) {
11551        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11552           decc_bug_devnull = 1;
11553        else
11554           decc_bug_devnull = 0;
11555     }
11556
11557     /* fgetname returning a VMS name in UNIX mode */
11558     decc_bug_fgetname = 1;
11559     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
11560     if ($VMS_STATUS_SUCCESS(status)) {
11561       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11562         decc_bug_fgetname = 1;
11563       else
11564         decc_bug_fgetname = 0;
11565     }
11566
11567     /* UNIX directory names with no paths are broken in a lot of places */
11568     decc_dir_barename = 1;
11569     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
11570     if ($VMS_STATUS_SUCCESS(status)) {
11571       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11572         decc_dir_barename = 1;
11573       else
11574         decc_dir_barename = 0;
11575     }
11576
11577 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11578     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
11579     if (s >= 0) {
11580         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
11581         if (decc_disable_to_vms_logname_translation < 0)
11582             decc_disable_to_vms_logname_translation = 0;
11583     }
11584
11585     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
11586     if (s >= 0) {
11587         decc_efs_case_preserve = decc$feature_get_value(s, 1);
11588         if (decc_efs_case_preserve < 0)
11589             decc_efs_case_preserve = 0;
11590     }
11591
11592     s = decc$feature_get_index("DECC$EFS_CHARSET");
11593     if (s >= 0) {
11594         decc_efs_charset = decc$feature_get_value(s, 1);
11595         if (decc_efs_charset < 0)
11596             decc_efs_charset = 0;
11597     }
11598
11599     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
11600     if (s >= 0) {
11601         decc_filename_unix_report = decc$feature_get_value(s, 1);
11602         if (decc_filename_unix_report > 0)
11603             decc_filename_unix_report = 1;
11604         else
11605             decc_filename_unix_report = 0;
11606     }
11607
11608     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
11609     if (s >= 0) {
11610         decc_filename_unix_only = decc$feature_get_value(s, 1);
11611         if (decc_filename_unix_only > 0) {
11612             decc_filename_unix_only = 1;
11613         }
11614         else {
11615             decc_filename_unix_only = 0;
11616         }
11617     }
11618
11619     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
11620     if (s >= 0) {
11621         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
11622         if (decc_filename_unix_no_version < 0)
11623             decc_filename_unix_no_version = 0;
11624     }
11625
11626     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
11627     if (s >= 0) {
11628         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
11629         if (decc_readdir_dropdotnotype < 0)
11630             decc_readdir_dropdotnotype = 0;
11631     }
11632
11633     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
11634     if ($VMS_STATUS_SUCCESS(status)) {
11635         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
11636         if (s >= 0) {
11637             dflt = decc$feature_get_value(s, 4);
11638             if (dflt > 0) {
11639                 decc_disable_posix_root = decc$feature_get_value(s, 1);
11640                 if (decc_disable_posix_root <= 0) {
11641                     decc$feature_set_value(s, 1, 1);
11642                     decc_disable_posix_root = 1;
11643                 }
11644             }
11645             else {
11646                 /* Traditionally Perl assumes this is off */
11647                 decc_disable_posix_root = 1;
11648                 decc$feature_set_value(s, 1, 1);
11649             }
11650         }
11651     }
11652
11653 #if __CRTL_VER >= 80200000
11654     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
11655     if (s >= 0) {
11656         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11657         if (decc_posix_compliant_pathnames < 0)
11658             decc_posix_compliant_pathnames = 0;
11659         if (decc_posix_compliant_pathnames > 4)
11660             decc_posix_compliant_pathnames = 0;
11661     }
11662
11663 #endif
11664 #else
11665     status = sys_trnlnm
11666         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11667     if ($VMS_STATUS_SUCCESS(status)) {
11668         val_str[0] = _toupper(val_str[0]);
11669         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11670            decc_disable_to_vms_logname_translation = 1;
11671         }
11672     }
11673
11674 #ifndef __VAX
11675     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11676     if ($VMS_STATUS_SUCCESS(status)) {
11677         val_str[0] = _toupper(val_str[0]);
11678         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11679            decc_efs_case_preserve = 1;
11680         }
11681     }
11682 #endif
11683
11684     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11685     if ($VMS_STATUS_SUCCESS(status)) {
11686         val_str[0] = _toupper(val_str[0]);
11687         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11688            decc_filename_unix_report = 1;
11689         }
11690     }
11691     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11692     if ($VMS_STATUS_SUCCESS(status)) {
11693         val_str[0] = _toupper(val_str[0]);
11694         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11695            decc_filename_unix_only = 1;
11696            decc_filename_unix_report = 1;
11697         }
11698     }
11699     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11700     if ($VMS_STATUS_SUCCESS(status)) {
11701         val_str[0] = _toupper(val_str[0]);
11702         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11703            decc_filename_unix_no_version = 1;
11704         }
11705     }
11706     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11707     if ($VMS_STATUS_SUCCESS(status)) {
11708         val_str[0] = _toupper(val_str[0]);
11709         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11710            decc_readdir_dropdotnotype = 1;
11711         }
11712     }
11713 #endif
11714
11715 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11716
11717      /* Report true case tolerance */
11718     /*----------------------------*/
11719     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11720     if (!$VMS_STATUS_SUCCESS(status))
11721         case_perm = PPROP$K_CASE_BLIND;
11722     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11723     if (!$VMS_STATUS_SUCCESS(status))
11724         case_image = PPROP$K_CASE_BLIND;
11725     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11726         (case_image == PPROP$K_CASE_SENSITIVE))
11727         vms_process_case_tolerant = 0;
11728
11729 #endif
11730
11731
11732     /* CRTL can be initialized past this point, but not before. */
11733 /*    DECC$CRTL_INIT(); */
11734
11735     return SS$_NORMAL;
11736 }
11737
11738 #ifdef __DECC
11739 /* DECC dependent attributes */
11740 #if __DECC_VER < 60560002
11741 #define relative
11742 #define not_executable
11743 #else
11744 #define relative ,rel
11745 #define not_executable ,noexe
11746 #endif
11747 #pragma nostandard
11748 #pragma extern_model save
11749 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11750 #endif
11751         const __align (LONGWORD) int spare[8] = {0};
11752 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11753 /*                        NOWRT, LONG */
11754 #ifdef __DECC
11755 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11756         nowrt,noshr relative not_executable
11757 #endif
11758 const long vms_cc_features = (const long)set_features;
11759
11760 /*
11761 ** Force a reference to LIB$INITIALIZE to ensure it
11762 ** exists in the image.
11763 */
11764 int lib$initialize(void);
11765 #ifdef __DECC
11766 #pragma extern_model strict_refdef
11767 #endif
11768     int lib_init_ref = (int) lib$initialize;
11769
11770 #ifdef __DECC
11771 #pragma extern_model restore
11772 #pragma standard
11773 #endif
11774
11775 /*  End of vms.c */