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