vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  * Version: 5.7.0
   5  *
   6  * August 2005 Convert VMS status code to UNIX status codes
   7  * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
   8  *             and Perl_cando by Craig Berry
   9  * 29-Aug-2000 Charles Lane's piping improvements rolled in
  10  * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  11  */
  12
  13 #include <acedef.h>
  14 #include <acldef.h>
  15 #include <armdef.h>
  16 #include <atrdef.h>
  17 #include <chpdef.h>
  18 #include <clidef.h>
  19 #include <climsgdef.h>
  20 #include <descrip.h>
  21 #include <devdef.h>
  22 #include <dvidef.h>
  23 #include <fibdef.h>
  24 #include <float.h>
  25 #include <fscndef.h>
  26 #include <iodef.h>
  27 #include <jpidef.h>
  28 #include <kgbdef.h>
  29 #include <libclidef.h>
  30 #include <libdef.h>
  31 #include <lib$routines.h>
  32 #include <lnmdef.h>
  33 #include <msgdef.h>
  34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  35 #include <ppropdef.h>
  36 #endif
  37 #include <prvdef.h>
  38 #include <psldef.h>
  39 #include <rms.h>
  40 #include <shrdef.h>
  41 #include <ssdef.h>
  42 #include <starlet.h>
  43 #include <strdef.h>
  44 #include <str$routines.h>
  45 #include <syidef.h>
  46 #include <uaidef.h>
  47 #include <uicdef.h>
  48 #include <stsdef.h>
  49 #include <rmsdef.h>
  50
  51 /* Set the maximum filespec size here as it is larger for EFS file
  52  * specifications.
  53  * Not fully implemented at this time because the larger size
  54  * will likely impact the stack local storage requirements of
  55  * threaded code, and probably cause hard to diagnose failures.
  56  * To implement the larger sizes, all places where filename
  57  * storage is put on the stack need to be changed to use
  58  * New()/SafeFree() instead.
  59  */
  60 #ifndef __VAX
  61 #ifndef VMS_MAXRSS
  62 #ifdef NAML$C_MAXRSS
  63 #define VMS_MAXRSS (NAML$C_MAXRSS+1)
  64 #ifndef VMS_LONGNAME_SUPPORT
  65 #define VMS_LONGNAME_SUPPORT 1
  66 #endif /* VMS_LONGNAME_SUPPORT */
  67 #endif /* NAML$C_MAXRSS */
  68 #endif /* VMS_MAXRSS */
  69 #endif
  70
  71 /* temporary hack until support is complete */
  72 #ifdef VMS_LONGNAME_SUPPORT
  73 #undef VMS_LONGNAME_SUPPORT
  74 #undef VMS_MAXRSS
  75 #endif
  76 /* end of temporary hack until support is complete */
  77
  78 #ifndef VMS_MAXRSS
  79 #define VMS_MAXRSS (NAM$C_MAXRSS + 1)
  80 #endif
  81
  82 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  83 int   decc$feature_get_index(const char *name);
  84 char* decc$feature_get_name(int index);
  85 int   decc$feature_get_value(int index, int mode);
  86 int   decc$feature_set_value(int index, int mode, int value);
  87 #else
  88 #include <unixlib.h>
  89 #endif
  90
  91 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  92
  93 static int set_feature_default(const char *name, int value)
  94 {
  95     int status;
  96     int index;
  97
  98     index = decc$feature_get_index(name);
  99
 100     status = decc$feature_set_value(index, 1, value);
 101     if (index == -1 || (status == -1)) {
 102       return -1;
 103     }
 104
 105     status = decc$feature_get_value(index, 1);
 106     if (status != value) {
 107       return -1;
 108     }
 109
 110 return 0;
 111 }
 112 #endif
 113
 114 /* Older versions of ssdef.h don't have these */
 115 #ifndef SS$_INVFILFOROP
 116 #  define SS$_INVFILFOROP 3930
 117 #endif
 118 #ifndef SS$_NOSUCHOBJECT
 119 #  define SS$_NOSUCHOBJECT 2696
 120 #endif
 121
 122 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 123 #define PERLIO_NOT_STDIO 0
 124
 125 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 126  * code below needs to get to the underlying CRTL routines. */
 127 #define DONT_MASK_RTL_CALLS
 128 #include "EXTERN.h"
 129 #include "perl.h"
 130 #include "XSUB.h"
 131 /* Anticipating future expansion in lexical warnings . . . */
 132 #ifndef WARN_INTERNAL
 133 #  define WARN_INTERNAL WARN_MISC
 134 #endif
 135
 136 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 137 #  define RTL_USES_UTC 1
 138 #endif
 139
 140
 141 /* gcc's header files don't #define direct access macros
 142  * corresponding to VAXC's variant structs */
 143 #ifdef __GNUC__
 144 #  define uic$v_format uic$r_uic_form.uic$v_format
 145 #  define uic$v_group uic$r_uic_form.uic$v_group
 146 #  define uic$v_member uic$r_uic_form.uic$v_member
 147 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 148 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 149 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 150 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 151 #endif
 152
 153 #if defined(NEED_AN_H_ERRNO)
 154 dEXT int h_errno;
 155 #endif
 156
 157 #ifdef __DECC
 158 #pragma message disable pragma
 159 #pragma member_alignment save
 160 #pragma nomember_alignment longword
 161 #pragma message save
 162 #pragma message disable misalgndmem
 163 #endif
 164 struct itmlst_3 {
 165   unsigned short int buflen;
 166   unsigned short int itmcode;
 167   void *bufadr;
 168   unsigned short int *retlen;
 169 };
 170
 171 struct filescan_itmlst_2 {
 172     unsigned short length;
 173     unsigned short itmcode;
 174     char * component;
 175 };
 176
 177 struct vs_str_st {
 178     unsigned short length;
 179     char str[65536];
 180 };
 181
 182 #ifdef __DECC
 183 #pragma message restore
 184 #pragma member_alignment restore
 185 #endif
 186
 187 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
 188 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
 189 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
 190 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
 191 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
 192 #define do_vms_realpath(a,b)            mp_do_vms_realpath(aTHX_ a,b)
 193 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
 194 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
 195 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 196 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 197 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 198
 199 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
 200 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
 201 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
 202 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
 203
 204 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 205 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 206
 207 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 208  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 209  * the Perl facility.
 210  */
 211 #define PERL_LNM_MAX_ITER 10
 212
 213   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 214 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 215 #define MAX_DCL_SYMBOL          (8192)
 216 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 217 #else
 218 #define MAX_DCL_SYMBOL          (1024)
 219 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 220 #endif
 221
 222 static char *__mystrtolower(char *str)
 223 {
 224   if (str) for (; *str; ++str) *str= tolower(*str);
 225   return str;
 226 }
 227
 228 static struct dsc$descriptor_s fildevdsc =
 229   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 230 static struct dsc$descriptor_s crtlenvdsc =
 231   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 232 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 233 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 234 static struct dsc$descriptor_s **env_tables = defenv;
 235 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 236
 237 /* True if we shouldn't treat barewords as logicals during directory */
 238 /* munching */
 239 static int no_translate_barewords;
 240
 241 #ifndef RTL_USES_UTC
 242 static int tz_updated = 1;
 243 #endif
 244
 245 /* DECC Features that may need to affect how Perl interprets
 246  * displays filename information
 247  */
 248 static int decc_disable_to_vms_logname_translation = 1;
 249 static int decc_disable_posix_root = 1;
 250 int decc_efs_case_preserve = 0;
 251 static int decc_efs_charset = 0;
 252 static int decc_filename_unix_no_version = 0;
 253 static int decc_filename_unix_only = 0;
 254 int decc_filename_unix_report = 0;
 255 int decc_posix_compliant_pathnames = 0;
 256 int decc_readdir_dropdotnotype = 0;
 257 static int vms_process_case_tolerant = 1;
 258
 259 /* bug workarounds if needed */
 260 int decc_bug_readdir_efs1 = 0;
 261 int decc_bug_devnull = 1;
 262 int decc_bug_fgetname = 0;
 263 int decc_dir_barename = 0;
 264
 265 static int vms_debug_on_exception = 0;
 266
 267 /* Is this a UNIX file specification?
 268  *   No longer a simple check with EFS file specs
 269  *   For now, not a full check, but need to
 270  *   handle POSIX ^UP^ specifications
 271  *   Fixing to handle ^/ cases would require
 272  *   changes to many other conversion routines.
 273  */
 274
 275 static int is_unix_filespec(const char *path)
 276 {
 277 int ret_val;
 278 const char * pch1;
 279
 280     ret_val = 0;
 281     if (strncmp(path,"\"^UP^",5) != 0) {
 282         pch1 = strchr(path, '/');
 283         if (pch1 != NULL)
 284             ret_val = 1;
 285         else {
 286
 287             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 288             if (decc_filename_unix_report || decc_filename_unix_only) {
 289             if (strcmp(path,".") == 0)
 290                 ret_val = 1;
 291             }
 292         }
 293     }
 294     return ret_val;
 295 }
 296
 297 /* This handles the expansion of a '^' prefix to the proper character
 298  * in a UNIX file specification.
 299  *
 300  * The output count variable contains the number of characters added
 301  * to the output string.
 302  *
 303  * The return value is the number of characters read from the input
 304  * string
 305  */
 306 static int copy_expand_vms_filename_escape
 307   (char *outspec, const char *inspec, int *output_cnt)
 308 {
 309 int count;
 310 int scnt;
 311
 312     count = 0;
 313     *output_cnt = 0;
 314     if (*inspec == '^') {
 315         inspec++;
 316         switch (*inspec) {
 317         case '.':
 318             /* Non trailing dots should just be passed through */
 319             *outspec = *inspec;
 320             count++;
 321             (*output_cnt)++;
 322             break;
 323         case '_': /* space */
 324             *outspec = ' ';
 325             inspec++;
 326             count++;
 327             (*output_cnt)++;
 328             break;
 329         case 'U': /* Unicode */
 330             inspec++;
 331             count++;
 332             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 333             if (scnt == 4) {
 334                 unsigned int c1, c2;
 335                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 336                 outspec[0] == c1 & 0xff;
 337                 outspec[1] == c2 & 0xff;
 338                 if (scnt > 1) {
 339                     (*output_cnt) += 2;
 340                     count += 4;
 341                 }
 342             }
 343             else {
 344                 /* Error - do best we can to continue */
 345                 *outspec = 'U';
 346                 outspec++;
 347                 (*output_cnt++);
 348                 *outspec = *inspec;
 349                 count++;
 350                 (*output_cnt++);
 351             }
 352             break;
 353         default:
 354             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 355             if (scnt == 2) {
 356                 /* Hex encoded */
 357                 unsigned int c1;
 358                 scnt = sscanf(inspec, "%2x", &c1);
 359                 outspec[0] = c1 & 0xff;
 360                 if (scnt > 0) {
 361                     (*output_cnt++);
 362                     count += 2;
 363                 }
 364             }
 365             else {
 366                 *outspec = *inspec;
 367                 count++;
 368                 (*output_cnt++);
 369             }
 370         }
 371     }
 372     else {
 373         *outspec = *inspec;
 374         count++;
 375         (*output_cnt)++;
 376     }
 377     return count;
 378 }
 379
 380
 381 int SYS$FILESCAN
 382    (const struct dsc$descriptor_s * srcstr,
 383     struct filescan_itmlst_2 * valuelist,
 384     unsigned long * fldflags,
 385     struct dsc$descriptor_s *auxout,
 386     unsigned short * retlen);
 387
 388 /* vms_split_path - Verify that the input file specification is a
 389  * VMS format file specification, and provide pointers to the components of
 390  * it.  With EFS format filenames, this is virtually the only way to
 391  * parse a VMS path specification into components.
 392  *
 393  * If the sum of the components do not add up to the length of the
 394  * string, then the passed file specification is probably a UNIX style
 395  * path.
 396  */
 397 static int vms_split_path
 398    (pTHX_ const char * path,
 399     char * * volume,
 400     int * vol_len,
 401     char * * root,
 402     int * root_len,
 403     char * * dir,
 404     int * dir_len,
 405     char * * name,
 406     int * name_len,
 407     char * * ext,
 408     int * ext_len,
 409     char * * version,
 410     int * ver_len)
 411 {
 412 struct dsc$descriptor path_desc;
 413 int status;
 414 unsigned long flags;
 415 int ret_stat;
 416 struct filescan_itmlst_2 item_list[9];
 417 const int filespec = 0;
 418 const int nodespec = 1;
 419 const int devspec = 2;
 420 const int rootspec = 3;
 421 const int dirspec = 4;
 422 const int namespec = 5;
 423 const int typespec = 6;
 424 const int verspec = 7;
 425
 426     /* Assume the worst for an easy exit */
 427     ret_stat = -1;
 428     *volume = NULL;
 429     *vol_len = 0;
 430     *root = NULL;
 431     *root_len = 0;
 432     *dir = NULL;
 433     *dir_len;
 434     *name = NULL;
 435     *name_len = 0;
 436     *ext = NULL;
 437     *ext_len = 0;
 438     *version = NULL;
 439     *ver_len = 0;
 440
 441     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 442     path_desc.dsc$w_length = strlen(path);
 443     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 444     path_desc.dsc$b_class = DSC$K_CLASS_S;
 445
 446     /* Get the total length, if it is shorter than the string passed
 447      * then this was probably not a VMS formatted file specification
 448      */
 449     item_list[filespec].itmcode = FSCN$_FILESPEC;
 450     item_list[filespec].length = 0;
 451     item_list[filespec].component = NULL;
 452
 453     /* If the node is present, then it gets considered as part of the
 454      * volume name to hopefully make things simple.
 455      */
 456     item_list[nodespec].itmcode = FSCN$_NODE;
 457     item_list[nodespec].length = 0;
 458     item_list[nodespec].component = NULL;
 459
 460     item_list[devspec].itmcode = FSCN$_DEVICE;
 461     item_list[devspec].length = 0;
 462     item_list[devspec].component = NULL;
 463
 464     /* root is a special case,  adding it to either the directory or
 465      * the device components will probalby complicate things for the
 466      * callers of this routine, so leave it separate.
 467      */
 468     item_list[rootspec].itmcode = FSCN$_ROOT;
 469     item_list[rootspec].length = 0;
 470     item_list[rootspec].component = NULL;
 471
 472     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 473     item_list[dirspec].length = 0;
 474     item_list[dirspec].component = NULL;
 475
 476     item_list[namespec].itmcode = FSCN$_NAME;
 477     item_list[namespec].length = 0;
 478     item_list[namespec].component = NULL;
 479
 480     item_list[typespec].itmcode = FSCN$_TYPE;
 481     item_list[typespec].length = 0;
 482     item_list[typespec].component = NULL;
 483
 484     item_list[verspec].itmcode = FSCN$_VERSION;
 485     item_list[verspec].length = 0;
 486     item_list[verspec].component = NULL;
 487
 488     item_list[8].itmcode = 0;
 489     item_list[8].length = 0;
 490     item_list[8].component = NULL;
 491
 492     status = SYS$FILESCAN
 493        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 494         &flags, NULL, NULL);
 495     _ckvmssts(status); /* All failure status values indicate a coding error */
 496
 497     /* If we parsed it successfully these two lengths should be the same */
 498     if (path_desc.dsc$w_length != item_list[filespec].length)
 499         return ret_stat;
 500
 501     /* If we got here, then it is a VMS file specification */
 502     ret_stat = 0;
 503
 504     /* set the volume name */
 505     if (item_list[nodespec].length > 0) {
 506         *volume = item_list[nodespec].component;
 507         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 508     }
 509     else {
 510         *volume = item_list[devspec].component;
 511         *vol_len = item_list[devspec].length;
 512     }
 513
 514     *root = item_list[rootspec].component;
 515     *root_len = item_list[rootspec].length;
 516
 517     *dir = item_list[dirspec].component;
 518     *dir_len = item_list[dirspec].length;
 519
 520     /* Now fun with versions and EFS file specifications
 521      * The parser can not tell the difference when a "." is a version
 522      * delimiter or a part of the file specification.
 523      */
 524     if ((decc_efs_charset) &&
 525         (item_list[verspec].length > 0) &&
 526         (item_list[verspec].component[0] == '.')) {
 527         *name = item_list[namespec].component;
 528         *name_len = item_list[namespec].length + item_list[typespec].length;
 529         *ext = item_list[verspec].component;
 530         *ext_len = item_list[verspec].length;
 531         *version = NULL;
 532         *ver_len = 0;
 533     }
 534     else {
 535         *name = item_list[namespec].component;
 536         *name_len = item_list[namespec].length;
 537         *ext = item_list[typespec].component;
 538         *ext_len = item_list[typespec].length;
 539         *version = item_list[verspec].component;
 540         *ver_len = item_list[verspec].length;
 541     }
 542     return ret_stat;
 543 }
 544
 545
 546 /* my_maxidx
 547  * Routine to retrieve the maximum equivalence index for an input
 548  * logical name.  Some calls to this routine have no knowledge if
 549  * the variable is a logical or not.  So on error we return a max
 550  * index of zero.
 551  */
 552 /*{{{int my_maxidx(const char *lnm) */
 553 static int
 554 my_maxidx(const char *lnm)
 555 {
 556     int status;
 557     int midx;
 558     int attr = LNM$M_CASE_BLIND;
 559     struct dsc$descriptor lnmdsc;
 560     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 561                                 {0, 0, 0, 0}};
 562
 563     lnmdsc.dsc$w_length = strlen(lnm);
 564     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 565     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 566     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 567
 568     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 569     if ((status & 1) == 0)
 570        midx = 0;
 571
 572     return (midx);
 573 }
 574 /*}}}*/
 575
 576 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 577 int
 578 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 579   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 580 {
 581     const char *cp1;
 582     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 583     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 584     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 585     int midx;
 586     unsigned char acmode;
 587     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 588                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 589     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 590                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 591                                  {0, 0, 0, 0}};
 592     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 593 #if defined(PERL_IMPLICIT_CONTEXT)
 594     pTHX = NULL;
 595     if (PL_curinterp) {
 596       aTHX = PERL_GET_INTERP;
 597     } else {
 598       aTHX = NULL;
 599     }
 600 #endif
 601
 602     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 603       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 604     }
 605     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 606       *cp2 = _toupper(*cp1);
 607       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 608         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 609         return 0;
 610       }
 611     }
 612     lnmdsc.dsc$w_length = cp1 - lnm;
 613     lnmdsc.dsc$a_pointer = uplnm;
 614     uplnm[lnmdsc.dsc$w_length] = '\0';
 615     secure = flags & PERL__TRNENV_SECURE;
 616     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 617     if (!tabvec || !*tabvec) tabvec = env_tables;
 618
 619     for (curtab = 0; tabvec[curtab]; curtab++) {
 620       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 621         if (!ivenv && !secure) {
 622           char *eq, *end;
 623           int i;
 624           if (!environ) {
 625             ivenv = 1;
 626             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 627             continue;
 628           }
 629           retsts = SS$_NOLOGNAM;
 630           for (i = 0; environ[i]; i++) {
 631             if ((eq = strchr(environ[i],'=')) &&
 632                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 633                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 634               eq++;
 635               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 636               if (!eqvlen) continue;
 637               retsts = SS$_NORMAL;
 638               break;
 639             }
 640           }
 641           if (retsts != SS$_NOLOGNAM) break;
 642         }
 643       }
 644       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 645                !str$case_blind_compare(&tmpdsc,&clisym)) {
 646         if (!ivsym && !secure) {
 647           unsigned short int deflen = LNM$C_NAMLENGTH;
 648           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 649           /* dynamic dsc to accomodate possible long value */
 650           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 651           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 652           if (retsts & 1) {
 653             if (eqvlen > MAX_DCL_SYMBOL) {
 654               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 655               eqvlen = MAX_DCL_SYMBOL;
 656               /* Special hack--we might be called before the interpreter's */
 657               /* fully initialized, in which case either thr or PL_curcop */
 658               /* might be bogus. We have to check, since ckWARN needs them */
 659               /* both to be valid if running threaded */
 660                 if (ckWARN(WARN_MISC)) {
 661                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 662                 }
 663             }
 664             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 665           }
 666           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 667           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 668           if (retsts == LIB$_NOSUCHSYM) continue;
 669           break;
 670         }
 671       }
 672       else if (!ivlnm) {
 673         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 674           midx = my_maxidx(lnm);
 675           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 676             lnmlst[1].bufadr = cp2;
 677             eqvlen = 0;
 678             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 679             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 680             if (retsts == SS$_NOLOGNAM) break;
 681             /* PPFs have a prefix */
 682             if (
 683 #if INTSIZE == 4
 684                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 685 #endif
 686                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 687                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 688                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 689                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 690                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 691               memmove(eqv,eqv+4,eqvlen-4);
 692               eqvlen -= 4;
 693             }
 694             cp2 += eqvlen;
 695             *cp2 = '\0';
 696           }
 697           if ((retsts == SS$_IVLOGNAM) ||
 698               (retsts == SS$_NOLOGNAM)) { continue; }
 699         }
 700         else {
 701           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 702           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 703           if (retsts == SS$_NOLOGNAM) continue;
 704           eqv[eqvlen] = '\0';
 705         }
 706         eqvlen = strlen(eqv);
 707         break;
 708       }
 709     }
 710     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 711     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 712              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 713              retsts == SS$_NOLOGNAM) {
 714       set_errno(EINVAL);  set_vaxc_errno(retsts);
 715     }
 716     else _ckvmssts(retsts);
 717     return 0;
 718 }  /* end of vmstrnenv */
 719 /*}}}*/
 720
 721 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 722 /* Define as a function so we can access statics. */
 723 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 724 {
 725   return vmstrnenv(lnm,eqv,idx,fildev,
 726 #ifdef SECURE_INTERNAL_GETENV
 727                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 728 #else
 729                    0
 730 #endif
 731                                                                               );
 732 }
 733 /*}}}*/
 734
 735 /* my_getenv
 736  * Note: Uses Perl temp to store result so char * can be returned to
 737  * caller; this pointer will be invalidated at next Perl statement
 738  * transition.
 739  * We define this as a function rather than a macro in terms of my_getenv_len()
 740  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 741  * allocate SVs).
 742  */
 743 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 744 char *
 745 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 746 {
 747     const char *cp1;
 748     static char *__my_getenv_eqv = NULL;
 749     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 750     unsigned long int idx = 0;
 751     int trnsuccess, success, secure, saverr, savvmserr;
 752     int midx, flags;
 753     SV *tmpsv;
 754
 755     midx = my_maxidx(lnm) + 1;
 756
 757     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 758       /* Set up a temporary buffer for the return value; Perl will
 759        * clean it up at the next statement transition */
 760       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 761       if (!tmpsv) return NULL;
 762       eqv = SvPVX(tmpsv);
 763     }
 764     else {
 765       /* Assume no interpreter ==> single thread */
 766       if (__my_getenv_eqv != NULL) {
 767         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 768       }
 769       else {
 770         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 771       }
 772       eqv = __my_getenv_eqv;
 773     }
 774
 775     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 776     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 777       int len;
 778       getcwd(eqv,LNM$C_NAMLENGTH);
 779
 780       len = strlen(eqv);
 781
 782       /* Get rid of "000000/ in rooted filespecs */
 783       if (len > 7) {
 784         char * zeros;
 785         zeros = strstr(eqv, "/000000/");
 786         if (zeros != NULL) {
 787           int mlen;
 788           mlen = len - (zeros - eqv) - 7;
 789           memmove(zeros, &zeros[7], mlen);
 790           len = len - 7;
 791           eqv[len] = '\0';
 792         }
 793       }
 794       return eqv;
 795     }
 796     else {
 797       /* Impose security constraints only if tainting */
 798       if (sys) {
 799         /* Impose security constraints only if tainting */
 800         secure = PL_curinterp ? PL_tainting : will_taint;
 801         saverr = errno;  savvmserr = vaxc$errno;
 802       }
 803       else {
 804         secure = 0;
 805       }
 806
 807       flags =
 808 #ifdef SECURE_INTERNAL_GETENV
 809               secure ? PERL__TRNENV_SECURE : 0
 810 #else
 811               0
 812 #endif
 813       ;
 814
 815       /* For the getenv interface we combine all the equivalence names
 816        * of a search list logical into one value to acquire a maximum
 817        * value length of 255*128 (assuming %ENV is using logicals).
 818        */
 819       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 820
 821       /* If the name contains a semicolon-delimited index, parse it
 822        * off and make sure we only retrieve the equivalence name for
 823        * that index.  */
 824       if ((cp2 = strchr(lnm,';')) != NULL) {
 825         strcpy(uplnm,lnm);
 826         uplnm[cp2-lnm] = '\0';
 827         idx = strtoul(cp2+1,NULL,0);
 828         lnm = uplnm;
 829         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 830       }
 831
 832       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
 833
 834       /* Discard NOLOGNAM on internal calls since we're often looking
 835        * for an optional name, and this "error" often shows up as the
 836        * (bogus) exit status for a die() call later on.  */
 837       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 838       return success ? eqv : Nullch;
 839     }
 840
 841 }  /* end of my_getenv() */
 842 /*}}}*/
 843
 844
 845 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 846 char *
 847 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 848 {
 849     const char *cp1;
 850     char *buf, *cp2;
 851     unsigned long idx = 0;
 852     int midx, flags;
 853     static char *__my_getenv_len_eqv = NULL;
 854     int secure, saverr, savvmserr;
 855     SV *tmpsv;
 856
 857     midx = my_maxidx(lnm) + 1;
 858
 859     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 860       /* Set up a temporary buffer for the return value; Perl will
 861        * clean it up at the next statement transition */
 862       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 863       if (!tmpsv) return NULL;
 864       buf = SvPVX(tmpsv);
 865     }
 866     else {
 867       /* Assume no interpreter ==> single thread */
 868       if (__my_getenv_len_eqv != NULL) {
 869         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 870       }
 871       else {
 872         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 873       }
 874       buf = __my_getenv_len_eqv;
 875     }
 876
 877     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 878     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 879     char * zeros;
 880
 881       getcwd(buf,LNM$C_NAMLENGTH);
 882       *len = strlen(buf);
 883
 884       /* Get rid of "000000/ in rooted filespecs */
 885       if (*len > 7) {
 886       zeros = strstr(buf, "/000000/");
 887       if (zeros != NULL) {
 888         int mlen;
 889         mlen = *len - (zeros - buf) - 7;
 890         memmove(zeros, &zeros[7], mlen);
 891         *len = *len - 7;
 892         buf[*len] = '\0';
 893         }
 894       }
 895       return buf;
 896     }
 897     else {
 898       if (sys) {
 899         /* Impose security constraints only if tainting */
 900         secure = PL_curinterp ? PL_tainting : will_taint;
 901         saverr = errno;  savvmserr = vaxc$errno;
 902       }
 903       else {
 904         secure = 0;
 905       }
 906
 907       flags =
 908 #ifdef SECURE_INTERNAL_GETENV
 909               secure ? PERL__TRNENV_SECURE : 0
 910 #else
 911               0
 912 #endif
 913       ;
 914
 915       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 916
 917       if ((cp2 = strchr(lnm,';')) != NULL) {
 918         strcpy(buf,lnm);
 919         buf[cp2-lnm] = '\0';
 920         idx = strtoul(cp2+1,NULL,0);
 921         lnm = buf;
 922         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 923       }
 924
 925       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
 926
 927       /* Get rid of "000000/ in rooted filespecs */
 928       if (*len > 7) {
 929       char * zeros;
 930         zeros = strstr(buf, "/000000/");
 931         if (zeros != NULL) {
 932           int mlen;
 933           mlen = *len - (zeros - buf) - 7;
 934           memmove(zeros, &zeros[7], mlen);
 935           *len = *len - 7;
 936           buf[*len] = '\0';
 937         }
 938       }
 939
 940       /* Discard NOLOGNAM on internal calls since we're often looking
 941        * for an optional name, and this "error" often shows up as the
 942        * (bogus) exit status for a die() call later on.  */
 943       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 944       return *len ? buf : Nullch;
 945     }
 946
 947 }  /* end of my_getenv_len() */
 948 /*}}}*/
 949
 950 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 951
 952 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 953
 954 /*{{{ void prime_env_iter() */
 955 void
 956 prime_env_iter(void)
 957 /* Fill the %ENV associative array with all logical names we can
 958  * find, in preparation for iterating over it.
 959  */
 960 {
 961   static int primed = 0;
 962   HV *seenhv = NULL, *envhv;
 963   SV *sv = NULL;
 964   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 965   unsigned short int chan;
 966 #ifndef CLI$M_TRUSTED
 967 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 968 #endif
 969   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 970   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 971   long int i;
 972   bool have_sym = FALSE, have_lnm = FALSE;
 973   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 974   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 975   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 976   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 977   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 978 #if defined(PERL_IMPLICIT_CONTEXT)
 979   pTHX;
 980 #endif
 981 #if defined(USE_ITHREADS)
 982   static perl_mutex primenv_mutex;
 983   MUTEX_INIT(&primenv_mutex);
 984 #endif
 985
 986 #if defined(PERL_IMPLICIT_CONTEXT)
 987     /* We jump through these hoops because we can be called at */
 988     /* platform-specific initialization time, which is before anything is */
 989     /* set up--we can't even do a plain dTHX since that relies on the */
 990     /* interpreter structure to be initialized */
 991     if (PL_curinterp) {
 992       aTHX = PERL_GET_INTERP;
 993     } else {
 994       aTHX = NULL;
 995     }
 996 #endif
 997
 998   if (primed || !PL_envgv) return;
 999   MUTEX_LOCK(&primenv_mutex);
1000   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1001   envhv = GvHVn(PL_envgv);
1002   /* Perform a dummy fetch as an lval to insure that the hash table is
1003    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1004   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1005
1006   for (i = 0; env_tables[i]; i++) {
1007      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1008          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1009      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1010   }
1011   if (have_sym || have_lnm) {
1012     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1013     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1014     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1015     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1016   }
1017
1018   for (i--; i >= 0; i--) {
1019     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1020       char *start;
1021       int j;
1022       for (j = 0; environ[j]; j++) {
1023         if (!(start = strchr(environ[j],'='))) {
1024           if (ckWARN(WARN_INTERNAL))
1025             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1026         }
1027         else {
1028           start++;
1029           sv = newSVpv(start,0);
1030           SvTAINTED_on(sv);
1031           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1032         }
1033       }
1034       continue;
1035     }
1036     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1037              !str$case_blind_compare(&tmpdsc,&clisym)) {
1038       strcpy(cmd,"Show Symbol/Global *");
1039       cmddsc.dsc$w_length = 20;
1040       if (env_tables[i]->dsc$w_length == 12 &&
1041           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1042           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1043       flags = defflags | CLI$M_NOLOGNAM;
1044     }
1045     else {
1046       strcpy(cmd,"Show Logical *");
1047       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1048         strcat(cmd," /Table=");
1049         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1050         cmddsc.dsc$w_length = strlen(cmd);
1051       }
1052       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1053       flags = defflags | CLI$M_NOCLISYM;
1054     }
1055
1056     /* Create a new subprocess to execute each command, to exclude the
1057      * remote possibility that someone could subvert a mbx or file used
1058      * to write multiple commands to a single subprocess.
1059      */
1060     do {
1061       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1062                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1063       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1064       defflags &= ~CLI$M_TRUSTED;
1065     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1066     _ckvmssts(retsts);
1067     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1068     if (seenhv) SvREFCNT_dec(seenhv);
1069     seenhv = newHV();
1070     while (1) {
1071       char *cp1, *cp2, *key;
1072       unsigned long int sts, iosb[2], retlen, keylen;
1073       register U32 hash;
1074
1075       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1076       if (sts & 1) sts = iosb[0] & 0xffff;
1077       if (sts == SS$_ENDOFFILE) {
1078         int wakect = 0;
1079         while (substs == 0) { sys$hiber(); wakect++;}
1080         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1081         _ckvmssts(substs);
1082         break;
1083       }
1084       _ckvmssts(sts);
1085       retlen = iosb[0] >> 16;
1086       if (!retlen) continue;  /* blank line */
1087       buf[retlen] = '\0';
1088       if (iosb[1] != subpid) {
1089         if (iosb[1]) {
1090           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1091         }
1092         continue;
1093       }
1094       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1095         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1096
1097       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1098       if (*cp1 == '(' || /* Logical name table name */
1099           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1100       if (*cp1 == '"') cp1++;
1101       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1102       key = cp1;  keylen = cp2 - cp1;
1103       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1104       while (*cp2 && *cp2 != '=') cp2++;
1105       while (*cp2 && *cp2 == '=') cp2++;
1106       while (*cp2 && *cp2 == ' ') cp2++;
1107       if (*cp2 == '"') {  /* String translation; may embed "" */
1108         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1109         cp2++;  cp1--; /* Skip "" surrounding translation */
1110       }
1111       else {  /* Numeric translation */
1112         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1113         cp1--;  /* stop on last non-space char */
1114       }
1115       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1116         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1117         continue;
1118       }
1119       PERL_HASH(hash,key,keylen);
1120
1121       if (cp1 == cp2 && *cp2 == '.') {
1122         /* A single dot usually means an unprintable character, such as a null
1123          * to indicate a zero-length value.  Get the actual value to make sure.
1124          */
1125         char lnm[LNM$C_NAMLENGTH+1];
1126         char eqv[MAX_DCL_SYMBOL+1];
1127         strncpy(lnm, key, keylen);
1128         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1129         sv = newSVpvn(eqv, strlen(eqv));
1130       }
1131       else {
1132         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1133       }
1134
1135       SvTAINTED_on(sv);
1136       hv_store(envhv,key,keylen,sv,hash);
1137       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1138     }
1139     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1140       /* get the PPFs for this process, not the subprocess */
1141       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1142       char eqv[LNM$C_NAMLENGTH+1];
1143       int trnlen, i;
1144       for (i = 0; ppfs[i]; i++) {
1145         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1146         sv = newSVpv(eqv,trnlen);
1147         SvTAINTED_on(sv);
1148         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1149       }
1150     }
1151   }
1152   primed = 1;
1153   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1154   if (buf) Safefree(buf);
1155   if (seenhv) SvREFCNT_dec(seenhv);
1156   MUTEX_UNLOCK(&primenv_mutex);
1157   return;
1158
1159 }  /* end of prime_env_iter */
1160 /*}}}*/
1161
1162
1163 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1164 /* Define or delete an element in the same "environment" as
1165  * vmstrnenv().  If an element is to be deleted, it's removed from
1166  * the first place it's found.  If it's to be set, it's set in the
1167  * place designated by the first element of the table vector.
1168  * Like setenv() returns 0 for success, non-zero on error.
1169  */
1170 int
1171 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1172 {
1173     const char *cp1;
1174     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1175     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1176     int nseg = 0, j;
1177     unsigned long int retsts, usermode = PSL$C_USER;
1178     struct itmlst_3 *ile, *ilist;
1179     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1180                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1181                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1182     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1183     $DESCRIPTOR(local,"_LOCAL");
1184
1185     if (!lnm) {
1186         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1187         return SS$_IVLOGNAM;
1188     }
1189
1190     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1191       *cp2 = _toupper(*cp1);
1192       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1193         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1194         return SS$_IVLOGNAM;
1195       }
1196     }
1197     lnmdsc.dsc$w_length = cp1 - lnm;
1198     if (!tabvec || !*tabvec) tabvec = env_tables;
1199
1200     if (!eqv) {  /* we're deleting n element */
1201       for (curtab = 0; tabvec[curtab]; curtab++) {
1202         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1203         int i;
1204           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1205             if ((cp1 = strchr(environ[i],'=')) &&
1206                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1207                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1208 #ifdef HAS_SETENV
1209               return setenv(lnm,"",1) ? vaxc$errno : 0;
1210             }
1211           }
1212           ivenv = 1; retsts = SS$_NOLOGNAM;
1213 #else
1214               if (ckWARN(WARN_INTERNAL))
1215                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1216               ivenv = 1; retsts = SS$_NOSUCHPGM;
1217               break;
1218             }
1219           }
1220 #endif
1221         }
1222         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1223                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1224           unsigned int symtype;
1225           if (tabvec[curtab]->dsc$w_length == 12 &&
1226               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1227               !str$case_blind_compare(&tmpdsc,&local))
1228             symtype = LIB$K_CLI_LOCAL_SYM;
1229           else symtype = LIB$K_CLI_GLOBAL_SYM;
1230           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1231           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1232           if (retsts == LIB$_NOSUCHSYM) continue;
1233           break;
1234         }
1235         else if (!ivlnm) {
1236           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1237           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1238           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1239           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1240           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1241         }
1242       }
1243     }
1244     else {  /* we're defining a value */
1245       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1246 #ifdef HAS_SETENV
1247         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1248 #else
1249         if (ckWARN(WARN_INTERNAL))
1250           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1251         retsts = SS$_NOSUCHPGM;
1252 #endif
1253       }
1254       else {
1255         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1256         eqvdsc.dsc$w_length  = strlen(eqv);
1257         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1258             !str$case_blind_compare(&tmpdsc,&clisym)) {
1259           unsigned int symtype;
1260           if (tabvec[0]->dsc$w_length == 12 &&
1261               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1262                !str$case_blind_compare(&tmpdsc,&local))
1263             symtype = LIB$K_CLI_LOCAL_SYM;
1264           else symtype = LIB$K_CLI_GLOBAL_SYM;
1265           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1266         }
1267         else {
1268           if (!*eqv) eqvdsc.dsc$w_length = 1;
1269           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1270
1271             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1272             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1273               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1274                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1275               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1276               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1277             }
1278
1279             Newx(ilist,nseg+1,struct itmlst_3);
1280             ile = ilist;
1281             if (!ile) {
1282               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1283               return SS$_INSFMEM;
1284             }
1285             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1286
1287             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1288               ile->itmcode = LNM$_STRING;
1289               ile->bufadr = c;
1290               if ((j+1) == nseg) {
1291                 ile->buflen = strlen(c);
1292                 /* in case we are truncating one that's too long */
1293                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1294               }
1295               else {
1296                 ile->buflen = LNM$C_NAMLENGTH;
1297               }
1298             }
1299
1300             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1301             Safefree (ilist);
1302           }
1303           else {
1304             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1305           }
1306         }
1307       }
1308     }
1309     if (!(retsts & 1)) {
1310       switch (retsts) {
1311         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1312         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1313           set_errno(EVMSERR); break;
1314         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1315         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1316           set_errno(EINVAL); break;
1317         case SS$_NOPRIV:
1318           set_errno(EACCES);
1319         default:
1320           _ckvmssts(retsts);
1321           set_errno(EVMSERR);
1322        }
1323        set_vaxc_errno(retsts);
1324        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1325     }
1326     else {
1327       /* We reset error values on success because Perl does an hv_fetch()
1328        * before each hv_store(), and if the thing we're setting didn't
1329        * previously exist, we've got a leftover error message.  (Of course,
1330        * this fails in the face of
1331        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1332        * in that the error reported in $! isn't spurious,
1333        * but it's right more often than not.)
1334        */
1335       set_errno(0); set_vaxc_errno(retsts);
1336       return 0;
1337     }
1338
1339 }  /* end of vmssetenv() */
1340 /*}}}*/
1341
1342 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1343 /* This has to be a function since there's a prototype for it in proto.h */
1344 void
1345 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1346 {
1347     if (lnm && *lnm) {
1348       int len = strlen(lnm);
1349       if  (len == 7) {
1350         char uplnm[8];
1351         int i;
1352         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1353         if (!strcmp(uplnm,"DEFAULT")) {
1354           if (eqv && *eqv) my_chdir(eqv);
1355           return;
1356         }
1357     }
1358 #ifndef RTL_USES_UTC
1359     if (len == 6 || len == 2) {
1360       char uplnm[7];
1361       int i;
1362       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1363       uplnm[len] = '\0';
1364       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1365       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1366     }
1367 #endif
1368   }
1369   (void) vmssetenv(lnm,eqv,NULL);
1370 }
1371 /*}}}*/
1372
1373 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1374 /*  vmssetuserlnm
1375  *  sets a user-mode logical in the process logical name table
1376  *  used for redirection of sys$error
1377  */
1378 void
1379 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1380 {
1381     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1382     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1383     unsigned long int iss, attr = LNM$M_CONFINE;
1384     unsigned char acmode = PSL$C_USER;
1385     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1386                                  {0, 0, 0, 0}};
1387     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1388     d_name.dsc$w_length = strlen(name);
1389
1390     lnmlst[0].buflen = strlen(eqv);
1391     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1392
1393     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1394     if (!(iss&1)) lib$signal(iss);
1395 }
1396 /*}}}*/
1397
1398
1399 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1400 /* my_crypt - VMS password hashing
1401  * my_crypt() provides an interface compatible with the Unix crypt()
1402  * C library function, and uses sys$hash_password() to perform VMS
1403  * password hashing.  The quadword hashed password value is returned
1404  * as a NUL-terminated 8 character string.  my_crypt() does not change
1405  * the case of its string arguments; in order to match the behavior
1406  * of LOGINOUT et al., alphabetic characters in both arguments must
1407  *  be upcased by the caller.
1408  *
1409  * - fix me to call ACM services when available
1410  */
1411 char *
1412 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1413 {
1414 #   ifndef UAI$C_PREFERRED_ALGORITHM
1415 #     define UAI$C_PREFERRED_ALGORITHM 127
1416 #   endif
1417     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1418     unsigned short int salt = 0;
1419     unsigned long int sts;
1420     struct const_dsc {
1421         unsigned short int dsc$w_length;
1422         unsigned char      dsc$b_type;
1423         unsigned char      dsc$b_class;
1424         const char *       dsc$a_pointer;
1425     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1426        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1427     struct itmlst_3 uailst[3] = {
1428         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1429         { sizeof salt, UAI$_SALT,    &salt, 0},
1430         { 0,           0,            NULL,  NULL}};
1431     static char hash[9];
1432
1433     usrdsc.dsc$w_length = strlen(usrname);
1434     usrdsc.dsc$a_pointer = usrname;
1435     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1436       switch (sts) {
1437         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1438           set_errno(EACCES);
1439           break;
1440         case RMS$_RNF:
1441           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1442           break;
1443         default:
1444           set_errno(EVMSERR);
1445       }
1446       set_vaxc_errno(sts);
1447       if (sts != RMS$_RNF) return NULL;
1448     }
1449
1450     txtdsc.dsc$w_length = strlen(textpasswd);
1451     txtdsc.dsc$a_pointer = textpasswd;
1452     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1453       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1454     }
1455
1456     return (char *) hash;
1457
1458 }  /* end of my_crypt() */
1459 /*}}}*/
1460
1461
1462 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1463 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1464 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1465
1466 /* fixup barenames that are directories for internal use.
1467  * There have been problems with the consistent handling of UNIX
1468  * style directory names when routines are presented with a name that
1469  * has no directory delimitors at all.  So this routine will eventually
1470  * fix the issue.
1471  */
1472 static char * fixup_bare_dirnames(const char * name)
1473 {
1474   if (decc_disable_to_vms_logname_translation) {
1475 /* fix me */
1476   }
1477   return NULL;
1478 }
1479
1480 /* mp_do_kill_file
1481  * A little hack to get around a bug in some implemenation of remove()
1482  * that do not know how to delete a directory
1483  *
1484  * Delete any file to which user has control access, regardless of whether
1485  * delete access is explicitly allowed.
1486  * Limitations: User must have write access to parent directory.
1487  *              Does not block signals or ASTs; if interrupted in midstream
1488  *              may leave file with an altered ACL.
1489  * HANDLE WITH CARE!
1490  */
1491 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1492 static int
1493 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1494 {
1495     char *vmsname, *rspec;
1496     char *remove_name;
1497     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1498     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1499     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1500     struct myacedef {
1501       unsigned char myace$b_length;
1502       unsigned char myace$b_type;
1503       unsigned short int myace$w_flags;
1504       unsigned long int myace$l_access;
1505       unsigned long int myace$l_ident;
1506     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1507                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1508       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1509      struct itmlst_3
1510        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1511                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1512        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1513        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1514        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1515        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1516
1517     /* Expand the input spec using RMS, since the CRTL remove() and
1518      * system services won't do this by themselves, so we may miss
1519      * a file "hiding" behind a logical name or search list. */
1520     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1521     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1522
1523     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1524       PerlMem_free(vmsname);
1525       return -1;
1526     }
1527
1528     if (decc_posix_compliant_pathnames) {
1529       /* In POSIX mode, we prefer to remove the UNIX name */
1530       rspec = vmsname;
1531       remove_name = (char *)name;
1532     }
1533     else {
1534       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1535       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1536       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1537         PerlMem_free(rspec);
1538         PerlMem_free(vmsname);
1539         return -1;
1540       }
1541       PerlMem_free(vmsname);
1542       remove_name = rspec;
1543     }
1544
1545 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1546     if (dirflag != 0) {
1547         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1548           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1549           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1550
1551           do_pathify_dirspec(name, remove_name, 0);
1552           if (!rmdir(remove_name)) {
1553
1554             PerlMem_free(remove_name);
1555             PerlMem_free(rspec);
1556             return 0;   /* Can we just get rid of it? */
1557           }
1558         }
1559         else {
1560           if (!rmdir(remove_name)) {
1561             PerlMem_free(rspec);
1562             return 0;   /* Can we just get rid of it? */
1563           }
1564         }
1565     }
1566     else
1567 #endif
1568       if (!remove(remove_name)) {
1569         PerlMem_free(rspec);
1570         return 0;   /* Can we just get rid of it? */
1571       }
1572
1573     /* If not, can changing protections help? */
1574     if (vaxc$errno != RMS$_PRV) {
1575       PerlMem_free(rspec);
1576       return -1;
1577     }
1578
1579     /* No, so we get our own UIC to use as a rights identifier,
1580      * and the insert an ACE at the head of the ACL which allows us
1581      * to delete the file.
1582      */
1583     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1584     fildsc.dsc$w_length = strlen(rspec);
1585     fildsc.dsc$a_pointer = rspec;
1586     cxt = 0;
1587     newace.myace$l_ident = oldace.myace$l_ident;
1588     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1589       switch (aclsts) {
1590         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1591           set_errno(ENOENT); break;
1592         case RMS$_DIR:
1593           set_errno(ENOTDIR); break;
1594         case RMS$_DEV:
1595           set_errno(ENODEV); break;
1596         case RMS$_SYN: case SS$_INVFILFOROP:
1597           set_errno(EINVAL); break;
1598         case RMS$_PRV:
1599           set_errno(EACCES); break;
1600         default:
1601           _ckvmssts(aclsts);
1602       }
1603       set_vaxc_errno(aclsts);
1604       PerlMem_free(rspec);
1605       return -1;
1606     }
1607     /* Grab any existing ACEs with this identifier in case we fail */
1608     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1609     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1610                     || fndsts == SS$_NOMOREACE ) {
1611       /* Add the new ACE . . . */
1612       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1613         goto yourroom;
1614
1615 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1616       if (dirflag != 0)
1617         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1618           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1619           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1620
1621           do_pathify_dirspec(name, remove_name, 0);
1622           rmsts = rmdir(remove_name);
1623           PerlMem_free(remove_name);
1624         }
1625         else {
1626         rmsts = rmdir(remove_name);
1627         }
1628       else
1629 #endif
1630         rmsts = remove(remove_name);
1631       if (rmsts) {
1632         /* We blew it - dir with files in it, no write priv for
1633          * parent directory, etc.  Put things back the way they were. */
1634         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1635           goto yourroom;
1636         if (fndsts & 1) {
1637           addlst[0].bufadr = &oldace;
1638           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1639             goto yourroom;
1640         }
1641       }
1642     }
1643
1644     yourroom:
1645     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1646     /* We just deleted it, so of course it's not there.  Some versions of
1647      * VMS seem to return success on the unlock operation anyhow (after all
1648      * the unlock is successful), but others don't.
1649      */
1650     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1651     if (aclsts & 1) aclsts = fndsts;
1652     if (!(aclsts & 1)) {
1653       set_errno(EVMSERR);
1654       set_vaxc_errno(aclsts);
1655       PerlMem_free(rspec);
1656       return -1;
1657     }
1658
1659     PerlMem_free(rspec);
1660     return rmsts;
1661
1662 }  /* end of kill_file() */
1663 /*}}}*/
1664
1665
1666 /*{{{int do_rmdir(char *name)*/
1667 int
1668 Perl_do_rmdir(pTHX_ const char *name)
1669 {
1670     char dirfile[NAM$C_MAXRSS+1];
1671     int retval;
1672     Stat_t st;
1673
1674     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1675     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1676     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1677     return retval;
1678
1679 }  /* end of do_rmdir */
1680 /*}}}*/
1681
1682 /* kill_file
1683  * Delete any file to which user has control access, regardless of whether
1684  * delete access is explicitly allowed.
1685  * Limitations: User must have write access to parent directory.
1686  *              Does not block signals or ASTs; if interrupted in midstream
1687  *              may leave file with an altered ACL.
1688  * HANDLE WITH CARE!
1689  */
1690 /*{{{int kill_file(char *name)*/
1691 int
1692 Perl_kill_file(pTHX_ const char *name)
1693 {
1694     char rspec[NAM$C_MAXRSS+1];
1695     char *tspec;
1696     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1697     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1698     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1699     struct myacedef {
1700       unsigned char myace$b_length;
1701       unsigned char myace$b_type;
1702       unsigned short int myace$w_flags;
1703       unsigned long int myace$l_access;
1704       unsigned long int myace$l_ident;
1705     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1706                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1707       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1708      struct itmlst_3
1709        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1710                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1711        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1712        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1713        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1714        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1715
1716     /* Expand the input spec using RMS, since the CRTL remove() and
1717      * system services won't do this by themselves, so we may miss
1718      * a file "hiding" behind a logical name or search list. */
1719     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS);
1720     if (tspec == NULL) return -1;
1721     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1722     /* If not, can changing protections help? */
1723     if (vaxc$errno != RMS$_PRV) return -1;
1724
1725     /* No, so we get our own UIC to use as a rights identifier,
1726      * and the insert an ACE at the head of the ACL which allows us
1727      * to delete the file.
1728      */
1729     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1730     fildsc.dsc$w_length = strlen(rspec);
1731     fildsc.dsc$a_pointer = rspec;
1732     cxt = 0;
1733     newace.myace$l_ident = oldace.myace$l_ident;
1734     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1735       switch (aclsts) {
1736         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1737           set_errno(ENOENT); break;
1738         case RMS$_DIR:
1739           set_errno(ENOTDIR); break;
1740         case RMS$_DEV:
1741           set_errno(ENODEV); break;
1742         case RMS$_SYN: case SS$_INVFILFOROP:
1743           set_errno(EINVAL); break;
1744         case RMS$_PRV:
1745           set_errno(EACCES); break;
1746         default:
1747           _ckvmssts(aclsts);
1748       }
1749       set_vaxc_errno(aclsts);
1750       return -1;
1751     }
1752     /* Grab any existing ACEs with this identifier in case we fail */
1753     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1754     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1755                     || fndsts == SS$_NOMOREACE ) {
1756       /* Add the new ACE . . . */
1757       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1758         goto yourroom;
1759       if ((rmsts = remove(name))) {
1760         /* We blew it - dir with files in it, no write priv for
1761          * parent directory, etc.  Put things back the way they were. */
1762         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1763           goto yourroom;
1764         if (fndsts & 1) {
1765           addlst[0].bufadr = &oldace;
1766           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1767             goto yourroom;
1768         }
1769       }
1770     }
1771
1772     yourroom:
1773     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1774     /* We just deleted it, so of course it's not there.  Some versions of
1775      * VMS seem to return success on the unlock operation anyhow (after all
1776      * the unlock is successful), but others don't.
1777      */
1778     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1779     if (aclsts & 1) aclsts = fndsts;
1780     if (!(aclsts & 1)) {
1781       set_errno(EVMSERR);
1782       set_vaxc_errno(aclsts);
1783       return -1;
1784     }
1785
1786     return rmsts;
1787
1788 }  /* end of kill_file() */
1789 /*}}}*/
1790
1791
1792 /*{{{int my_mkdir(char *,Mode_t)*/
1793 int
1794 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1795 {
1796   STRLEN dirlen = strlen(dir);
1797
1798   /* zero length string sometimes gives ACCVIO */
1799   if (dirlen == 0) return -1;
1800
1801   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1802    * null file name/type.  However, it's commonplace under Unix,
1803    * so we'll allow it for a gain in portability.
1804    */
1805   if (dir[dirlen-1] == '/') {
1806     char *newdir = savepvn(dir,dirlen-1);
1807     int ret = mkdir(newdir,mode);
1808     Safefree(newdir);
1809     return ret;
1810   }
1811   else return mkdir(dir,mode);
1812 }  /* end of my_mkdir */
1813 /*}}}*/
1814
1815 /*{{{int my_chdir(char *)*/
1816 int
1817 Perl_my_chdir(pTHX_ const char *dir)
1818 {
1819   STRLEN dirlen = strlen(dir);
1820
1821   /* zero length string sometimes gives ACCVIO */
1822   if (dirlen == 0) return -1;
1823   const char *dir1;
1824
1825   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1826    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
1827    * so that existing scripts do not need to be changed.
1828    */
1829   dir1 = dir;
1830   while ((dirlen > 0) && (*dir1 == ' ')) {
1831     dir1++;
1832     dirlen--;
1833   }
1834
1835   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1836    * that implies
1837    * null file name/type.  However, it's commonplace under Unix,
1838    * so we'll allow it for a gain in portability.
1839    *
1840    * - Preview- '/' will be valid soon on VMS
1841    */
1842   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1843     char *newdir = savepvn(dir1,dirlen-1);
1844     int ret = chdir(newdir);
1845     Safefree(newdir);
1846     return ret;
1847   }
1848   else return chdir(dir1);
1849 }  /* end of my_chdir */
1850 /*}}}*/
1851
1852
1853 /*{{{FILE *my_tmpfile()*/
1854 FILE *
1855 my_tmpfile(void)
1856 {
1857   FILE *fp;
1858   char *cp;
1859
1860   if ((fp = tmpfile())) return fp;
1861
1862   cp = PerlMem_malloc(L_tmpnam+24);
1863   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1864
1865   if (decc_filename_unix_only == 0)
1866     strcpy(cp,"Sys$Scratch:");
1867   else
1868     strcpy(cp,"/tmp/");
1869   tmpnam(cp+strlen(cp));
1870   strcat(cp,".Perltmp");
1871   fp = fopen(cp,"w+","fop=dlt");
1872   PerlMem_free(cp);
1873   return fp;
1874 }
1875 /*}}}*/
1876
1877
1878 #ifndef HOMEGROWN_POSIX_SIGNALS
1879 /*
1880  * The C RTL's sigaction fails to check for invalid signal numbers so we
1881  * help it out a bit.  The docs are correct, but the actual routine doesn't
1882  * do what the docs say it will.
1883  */
1884 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1885 int
1886 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1887                    struct sigaction* oact)
1888 {
1889   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1890         SETERRNO(EINVAL, SS$_INVARG);
1891         return -1;
1892   }
1893   return sigaction(sig, act, oact);
1894 }
1895 /*}}}*/
1896 #endif
1897
1898 #ifdef KILL_BY_SIGPRC
1899 #include <errnodef.h>
1900
1901 /* We implement our own kill() using the undocumented system service
1902    sys$sigprc for one of two reasons:
1903
1904    1.) If the kill() in an older CRTL uses sys$forcex, causing the
1905    target process to do a sys$exit, which usually can't be handled
1906    gracefully...certainly not by Perl and the %SIG{} mechanism.
1907
1908    2.) If the kill() in the CRTL can't be called from a signal
1909    handler without disappearing into the ether, i.e., the signal
1910    it purportedly sends is never trapped. Still true as of VMS 7.3.
1911
1912    sys$sigprc has the same parameters as sys$forcex, but throws an exception
1913    in the target process rather than calling sys$exit.
1914
1915    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1916    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1917    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
1918    with condition codes C$_SIG0+nsig*8, catching the exception on the
1919    target process and resignaling with appropriate arguments.
1920
1921    But we don't have that VMS 7.0+ exception handler, so if you
1922    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
1923
1924    Also note that SIGTERM is listed in the docs as being "unimplemented",
1925    yet always seems to be signaled with a VMS condition code of 4 (and
1926    correctly handled for that code).  So we hardwire it in.
1927
1928    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1929    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
1930    than signalling with an unrecognized (and unhandled by CRTL) code.
1931 */
1932
1933 #define _MY_SIG_MAX 17
1934
1935 static unsigned int
1936 Perl_sig_to_vmscondition_int(int sig)
1937 {
1938     static unsigned int sig_code[_MY_SIG_MAX+1] =
1939     {
1940         0,                  /*  0 ZERO     */
1941         SS$_HANGUP,         /*  1 SIGHUP   */
1942         SS$_CONTROLC,       /*  2 SIGINT   */
1943         SS$_CONTROLY,       /*  3 SIGQUIT  */
1944         SS$_RADRMOD,        /*  4 SIGILL   */
1945         SS$_BREAK,          /*  5 SIGTRAP  */
1946         SS$_OPCCUS,         /*  6 SIGABRT  */
1947         SS$_COMPAT,         /*  7 SIGEMT   */
1948 #ifdef __VAX
1949         SS$_FLTOVF,         /*  8 SIGFPE VAX */
1950 #else
1951         SS$_HPARITH,        /*  8 SIGFPE AXP */
1952 #endif
1953         SS$_ABORT,          /*  9 SIGKILL  */
1954         SS$_ACCVIO,         /* 10 SIGBUS   */
1955         SS$_ACCVIO,         /* 11 SIGSEGV  */
1956         SS$_BADPARAM,       /* 12 SIGSYS   */
1957         SS$_NOMBX,          /* 13 SIGPIPE  */
1958         SS$_ASTFLT,         /* 14 SIGALRM  */
1959         4,                  /* 15 SIGTERM  */
1960         0,                  /* 16 SIGUSR1  */
1961         0                   /* 17 SIGUSR2  */
1962     };
1963
1964 #if __VMS_VER >= 60200000
1965     static int initted = 0;
1966     if (!initted) {
1967         initted = 1;
1968         sig_code[16] = C$_SIGUSR1;
1969         sig_code[17] = C$_SIGUSR2;
1970     }
1971 #endif
1972
1973     if (sig < _SIG_MIN) return 0;
1974     if (sig > _MY_SIG_MAX) return 0;
1975     return sig_code[sig];
1976 }
1977
1978 unsigned int
1979 Perl_sig_to_vmscondition(int sig)
1980 {
1981 #ifdef SS$_DEBUG
1982     if (vms_debug_on_exception != 0)
1983         lib$signal(SS$_DEBUG);
1984 #endif
1985     return Perl_sig_to_vmscondition_int(sig);
1986 }
1987
1988
1989 int
1990 Perl_my_kill(int pid, int sig)
1991 {
1992     dTHX;
1993     int iss;
1994     unsigned int code;
1995     int sys$sigprc(unsigned int *pidadr,
1996                      struct dsc$descriptor_s *prcname,
1997                      unsigned int code);
1998
1999      /* sig 0 means validate the PID */
2000     /*------------------------------*/
2001     if (sig == 0) {
2002         const unsigned long int jpicode = JPI$_PID;
2003         pid_t ret_pid;
2004         int status;
2005         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2006         if ($VMS_STATUS_SUCCESS(status))
2007            return 0;
2008         switch (status) {
2009         case SS$_NOSUCHNODE:
2010         case SS$_UNREACHABLE:
2011         case SS$_NONEXPR:
2012            errno = ESRCH;
2013            break;
2014         case SS$_NOPRIV:
2015            errno = EPERM;
2016            break;
2017         default:
2018            errno = EVMSERR;
2019         }
2020         vaxc$errno=status;
2021         return -1;
2022     }
2023
2024     code = Perl_sig_to_vmscondition_int(sig);
2025
2026     if (!code) {
2027         SETERRNO(EINVAL, SS$_BADPARAM);
2028         return -1;
2029     }
2030
2031     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2032      * signals are to be sent to multiple processes.
2033      *  pid = 0 - all processes in group except ones that the system exempts
2034      *  pid = -1 - all processes except ones that the system exempts
2035      *  pid = -n - all processes in group (abs(n)) except ...
2036      * For now, just report as not supported.
2037      */
2038
2039     if (pid <= 0) {
2040         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2041         return -1;
2042     }
2043
2044     iss = sys$sigprc((unsigned int *)&pid,0,code);
2045     if (iss&1) return 0;
2046
2047     switch (iss) {
2048       case SS$_NOPRIV:
2049         set_errno(EPERM);  break;
2050       case SS$_NONEXPR:
2051       case SS$_NOSUCHNODE:
2052       case SS$_UNREACHABLE:
2053         set_errno(ESRCH);  break;
2054       case SS$_INSFMEM:
2055         set_errno(ENOMEM); break;
2056       default:
2057         _ckvmssts(iss);
2058         set_errno(EVMSERR);
2059     }
2060     set_vaxc_errno(iss);
2061
2062     return -1;
2063 }
2064 #endif
2065
2066 /* Routine to convert a VMS status code to a UNIX status code.
2067 ** More tricky than it appears because of conflicting conventions with
2068 ** existing code.
2069 **
2070 ** VMS status codes are a bit mask, with the least significant bit set for
2071 ** success.
2072 **
2073 ** Special UNIX status of EVMSERR indicates that no translation is currently
2074 ** available, and programs should check the VMS status code.
2075 **
2076 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2077 ** decoding.
2078 */
2079
2080 #ifndef C_FACILITY_NO
2081 #define C_FACILITY_NO 0x350000
2082 #endif
2083 #ifndef DCL_IVVERB
2084 #define DCL_IVVERB 0x38090
2085 #endif
2086
2087 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2088 {
2089 int facility;
2090 int fac_sp;
2091 int msg_no;
2092 int msg_status;
2093 int unix_status;
2094
2095   /* Assume the best or the worst */
2096   if (vms_status & STS$M_SUCCESS)
2097     unix_status = 0;
2098   else
2099     unix_status = EVMSERR;
2100
2101   msg_status = vms_status & ~STS$M_CONTROL;
2102
2103   facility = vms_status & STS$M_FAC_NO;
2104   fac_sp = vms_status & STS$M_FAC_SP;
2105   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2106
2107   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2108     switch(msg_no) {
2109     case SS$_NORMAL:
2110         unix_status = 0;
2111         break;
2112     case SS$_ACCVIO:
2113         unix_status = EFAULT;
2114         break;
2115     case SS$_DEVOFFLINE:
2116         unix_status = EBUSY;
2117         break;
2118     case SS$_CLEARED:
2119         unix_status = ENOTCONN;
2120         break;
2121     case SS$_IVCHAN:
2122     case SS$_IVLOGNAM:
2123     case SS$_BADPARAM:
2124     case SS$_IVLOGTAB:
2125     case SS$_NOLOGNAM:
2126     case SS$_NOLOGTAB:
2127     case SS$_INVFILFOROP:
2128     case SS$_INVARG:
2129     case SS$_NOSUCHID:
2130     case SS$_IVIDENT:
2131         unix_status = EINVAL;
2132         break;
2133     case SS$_UNSUPPORTED:
2134         unix_status = ENOTSUP;
2135         break;
2136     case SS$_FILACCERR:
2137     case SS$_NOGRPPRV:
2138     case SS$_NOSYSPRV:
2139         unix_status = EACCES;
2140         break;
2141     case SS$_DEVICEFULL:
2142         unix_status = ENOSPC;
2143         break;
2144     case SS$_NOSUCHDEV:
2145         unix_status = ENODEV;
2146         break;
2147     case SS$_NOSUCHFILE:
2148     case SS$_NOSUCHOBJECT:
2149         unix_status = ENOENT;
2150         break;
2151     case SS$_ABORT:                                 /* Fatal case */
2152     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2153     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2154         unix_status = EINTR;
2155         break;
2156     case SS$_BUFFEROVF:
2157         unix_status = E2BIG;
2158         break;
2159     case SS$_INSFMEM:
2160         unix_status = ENOMEM;
2161         break;
2162     case SS$_NOPRIV:
2163         unix_status = EPERM;
2164         break;
2165     case SS$_NOSUCHNODE:
2166     case SS$_UNREACHABLE:
2167         unix_status = ESRCH;
2168         break;
2169     case SS$_NONEXPR:
2170         unix_status = ECHILD;
2171         break;
2172     default:
2173         if ((facility == 0) && (msg_no < 8)) {
2174           /* These are not real VMS status codes so assume that they are
2175           ** already UNIX status codes
2176           */
2177           unix_status = msg_no;
2178           break;
2179         }
2180     }
2181   }
2182   else {
2183     /* Translate a POSIX exit code to a UNIX exit code */
2184     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2185         unix_status = (msg_no & 0x07F8) >> 3;
2186     }
2187     else {
2188
2189          /* Documented traditional behavior for handling VMS child exits */
2190         /*--------------------------------------------------------------*/
2191         if (child_flag != 0) {
2192
2193              /* Success / Informational return 0 */
2194             /*----------------------------------*/
2195             if (msg_no & STS$K_SUCCESS)
2196                 return 0;
2197
2198              /* Warning returns 1 */
2199             /*-------------------*/
2200             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2201                 return 1;
2202
2203              /* Everything else pass through the severity bits */
2204             /*------------------------------------------------*/
2205             return (msg_no & STS$M_SEVERITY);
2206         }
2207
2208          /* Normal VMS status to ERRNO mapping attempt */
2209         /*--------------------------------------------*/
2210         switch(msg_status) {
2211         /* case RMS$_EOF: */ /* End of File */
2212         case RMS$_FNF:  /* File Not Found */
2213         case RMS$_DNF:  /* Dir Not Found */
2214                 unix_status = ENOENT;
2215                 break;
2216         case RMS$_RNF:  /* Record Not Found */
2217                 unix_status = ESRCH;
2218                 break;
2219         case RMS$_DIR:
2220                 unix_status = ENOTDIR;
2221                 break;
2222         case RMS$_DEV:
2223                 unix_status = ENODEV;
2224                 break;
2225         case RMS$_IFI:
2226         case RMS$_FAC:
2227         case RMS$_ISI:
2228                 unix_status = EBADF;
2229                 break;
2230         case RMS$_FEX:
2231                 unix_status = EEXIST;
2232                 break;
2233         case RMS$_SYN:
2234         case RMS$_FNM:
2235         case LIB$_INVSTRDES:
2236         case LIB$_INVARG:
2237         case LIB$_NOSUCHSYM:
2238         case LIB$_INVSYMNAM:
2239         case DCL_IVVERB:
2240                 unix_status = EINVAL;
2241                 break;
2242         case CLI$_BUFOVF:
2243         case RMS$_RTB:
2244         case CLI$_TKNOVF:
2245         case CLI$_RSLOVF:
2246                 unix_status = E2BIG;
2247                 break;
2248         case RMS$_PRV:  /* No privilege */
2249         case RMS$_ACC:  /* ACP file access failed */
2250         case RMS$_WLK:  /* Device write locked */
2251                 unix_status = EACCES;
2252                 break;
2253         /* case RMS$_NMF: */  /* No more files */
2254         }
2255     }
2256   }
2257
2258   return unix_status;
2259 }
2260
2261 /* Try to guess at what VMS error status should go with a UNIX errno
2262  * value.  This is hard to do as there could be many possible VMS
2263  * error statuses that caused the errno value to be set.
2264  */
2265
2266 int Perl_unix_status_to_vms(int unix_status)
2267 {
2268 int test_unix_status;
2269
2270      /* Trivial cases first */
2271     /*---------------------*/
2272     if (unix_status == EVMSERR)
2273         return vaxc$errno;
2274
2275      /* Is vaxc$errno sane? */
2276     /*---------------------*/
2277     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2278     if (test_unix_status == unix_status)
2279         return vaxc$errno;
2280
2281      /* If way out of range, must be VMS code already */
2282     /*-----------------------------------------------*/
2283     if (unix_status > EVMSERR)
2284         return unix_status;
2285
2286      /* If out of range, punt */
2287     /*-----------------------*/
2288     if (unix_status > __ERRNO_MAX)
2289         return SS$_ABORT;
2290
2291
2292      /* Ok, now we have to do it the hard way. */
2293     /*----------------------------------------*/
2294     switch(unix_status) {
2295     case 0:     return SS$_NORMAL;
2296     case EPERM: return SS$_NOPRIV;
2297     case ENOENT: return SS$_NOSUCHOBJECT;
2298     case ESRCH: return SS$_UNREACHABLE;
2299     case EINTR: return SS$_ABORT;
2300     /* case EIO: */
2301     /* case ENXIO:  */
2302     case E2BIG: return SS$_BUFFEROVF;
2303     /* case ENOEXEC */
2304     case EBADF: return RMS$_IFI;
2305     case ECHILD: return SS$_NONEXPR;
2306     /* case EAGAIN */
2307     case ENOMEM: return SS$_INSFMEM;
2308     case EACCES: return SS$_FILACCERR;
2309     case EFAULT: return SS$_ACCVIO;
2310     /* case ENOTBLK */
2311     case EBUSY: return SS$_DEVOFFLINE;
2312     case EEXIST: return RMS$_FEX;
2313     /* case EXDEV */
2314     case ENODEV: return SS$_NOSUCHDEV;
2315     case ENOTDIR: return RMS$_DIR;
2316     /* case EISDIR */
2317     case EINVAL: return SS$_INVARG;
2318     /* case ENFILE */
2319     /* case EMFILE */
2320     /* case ENOTTY */
2321     /* case ETXTBSY */
2322     /* case EFBIG */
2323     case ENOSPC: return SS$_DEVICEFULL;
2324     case ESPIPE: return LIB$_INVARG;
2325     /* case EROFS: */
2326     /* case EMLINK: */
2327     /* case EPIPE: */
2328     /* case EDOM */
2329     case ERANGE: return LIB$_INVARG;
2330     /* case EWOULDBLOCK */
2331     /* case EINPROGRESS */
2332     /* case EALREADY */
2333     /* case ENOTSOCK */
2334     /* case EDESTADDRREQ */
2335     /* case EMSGSIZE */
2336     /* case EPROTOTYPE */
2337     /* case ENOPROTOOPT */
2338     /* case EPROTONOSUPPORT */
2339     /* case ESOCKTNOSUPPORT */
2340     /* case EOPNOTSUPP */
2341     /* case EPFNOSUPPORT */
2342     /* case EAFNOSUPPORT */
2343     /* case EADDRINUSE */
2344     /* case EADDRNOTAVAIL */
2345     /* case ENETDOWN */
2346     /* case ENETUNREACH */
2347     /* case ENETRESET */
2348     /* case ECONNABORTED */
2349     /* case ECONNRESET */
2350     /* case ENOBUFS */
2351     /* case EISCONN */
2352     case ENOTCONN: return SS$_CLEARED;
2353     /* case ESHUTDOWN */
2354     /* case ETOOMANYREFS */
2355     /* case ETIMEDOUT */
2356     /* case ECONNREFUSED */
2357     /* case ELOOP */
2358     /* case ENAMETOOLONG */
2359     /* case EHOSTDOWN */
2360     /* case EHOSTUNREACH */
2361     /* case ENOTEMPTY */
2362     /* case EPROCLIM */
2363     /* case EUSERS  */
2364     /* case EDQUOT  */
2365     /* case ENOMSG  */
2366     /* case EIDRM */
2367     /* case EALIGN */
2368     /* case ESTALE */
2369     /* case EREMOTE */
2370     /* case ENOLCK */
2371     /* case ENOSYS */
2372     /* case EFTYPE */
2373     /* case ECANCELED */
2374     /* case EFAIL */
2375     /* case EINPROG */
2376     case ENOTSUP:
2377         return SS$_UNSUPPORTED;
2378     /* case EDEADLK */
2379     /* case ENWAIT */
2380     /* case EILSEQ */
2381     /* case EBADCAT */
2382     /* case EBADMSG */
2383     /* case EABANDONED */
2384     default:
2385         return SS$_ABORT; /* punt */
2386     }
2387
2388   return SS$_ABORT; /* Should not get here */
2389 }
2390
2391
2392 /* default piping mailbox size */
2393 #define PERL_BUFSIZ        512
2394
2395
2396 static void
2397 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2398 {
2399   unsigned long int mbxbufsiz;
2400   static unsigned long int syssize = 0;
2401   unsigned long int dviitm = DVI$_DEVNAM;
2402   char csize[LNM$C_NAMLENGTH+1];
2403   int sts;
2404
2405   if (!syssize) {
2406     unsigned long syiitm = SYI$_MAXBUF;
2407     /*
2408      * Get the SYSGEN parameter MAXBUF
2409      *
2410      * If the logical 'PERL_MBX_SIZE' is defined
2411      * use the value of the logical instead of PERL_BUFSIZ, but
2412      * keep the size between 128 and MAXBUF.
2413      *
2414      */
2415     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2416   }
2417
2418   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2419       mbxbufsiz = atoi(csize);
2420   } else {
2421       mbxbufsiz = PERL_BUFSIZ;
2422   }
2423   if (mbxbufsiz < 128) mbxbufsiz = 128;
2424   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2425
2426   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2427
2428   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2429   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2430
2431 }  /* end of create_mbx() */
2432
2433
2434 /*{{{  my_popen and my_pclose*/
2435
2436 typedef struct _iosb           IOSB;
2437 typedef struct _iosb*         pIOSB;
2438 typedef struct _pipe           Pipe;
2439 typedef struct _pipe*         pPipe;
2440 typedef struct pipe_details    Info;
2441 typedef struct pipe_details*  pInfo;
2442 typedef struct _srqp            RQE;
2443 typedef struct _srqp*          pRQE;
2444 typedef struct _tochildbuf      CBuf;
2445 typedef struct _tochildbuf*    pCBuf;
2446
2447 struct _iosb {
2448     unsigned short status;
2449     unsigned short count;
2450     unsigned long  dvispec;
2451 };
2452
2453 #pragma member_alignment save
2454 #pragma nomember_alignment quadword
2455 struct _srqp {          /* VMS self-relative queue entry */
2456     unsigned long qptr[2];
2457 };
2458 #pragma member_alignment restore
2459 static RQE  RQE_ZERO = {0,0};
2460
2461 struct _tochildbuf {
2462     RQE             q;
2463     int             eof;
2464     unsigned short  size;
2465     char            *buf;
2466 };
2467
2468 struct _pipe {
2469     RQE            free;
2470     RQE            wait;
2471     int            fd_out;
2472     unsigned short chan_in;
2473     unsigned short chan_out;
2474     char          *buf;
2475     unsigned int   bufsize;
2476     IOSB           iosb;
2477     IOSB           iosb2;
2478     int           *pipe_done;
2479     int            retry;
2480     int            type;
2481     int            shut_on_empty;
2482     int            need_wake;
2483     pPipe         *home;
2484     pInfo          info;
2485     pCBuf          curr;
2486     pCBuf          curr2;
2487 #if defined(PERL_IMPLICIT_CONTEXT)
2488     void            *thx;           /* Either a thread or an interpreter */
2489                                     /* pointer, depending on how we're built */
2490 #endif
2491 };
2492
2493
2494 struct pipe_details
2495 {
2496     pInfo           next;
2497     PerlIO *fp;  /* file pointer to pipe mailbox */
2498     int useFILE; /* using stdio, not perlio */
2499     int pid;   /* PID of subprocess */
2500     int mode;  /* == 'r' if pipe open for reading */
2501     int done;  /* subprocess has completed */
2502     int waiting; /* waiting for completion/closure */
2503     int             closing;        /* my_pclose is closing this pipe */
2504     unsigned long   completion;     /* termination status of subprocess */
2505     pPipe           in;             /* pipe in to sub */
2506     pPipe           out;            /* pipe out of sub */
2507     pPipe           err;            /* pipe of sub's sys$error */
2508     int             in_done;        /* true when in pipe finished */
2509     int             out_done;
2510     int             err_done;
2511 };
2512
2513 struct exit_control_block
2514 {
2515     struct exit_control_block *flink;
2516     unsigned long int   (*exit_routine)();
2517     unsigned long int arg_count;
2518     unsigned long int *status_address;
2519     unsigned long int exit_status;
2520 };
2521
2522 typedef struct _closed_pipes    Xpipe;
2523 typedef struct _closed_pipes*  pXpipe;
2524
2525 struct _closed_pipes {
2526     int             pid;            /* PID of subprocess */
2527     unsigned long   completion;     /* termination status of subprocess */
2528 };
2529 #define NKEEPCLOSED 50
2530 static Xpipe closed_list[NKEEPCLOSED];
2531 static int   closed_index = 0;
2532 static int   closed_num = 0;
2533
2534 #define RETRY_DELAY     "0 ::0.20"
2535 #define MAX_RETRY              50
2536
2537 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2538 static unsigned long mypid;
2539 static unsigned long delaytime[2];
2540
2541 static pInfo open_pipes = NULL;
2542 static $DESCRIPTOR(nl_desc, "NL:");
2543
2544 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2545
2546
2547
2548 static unsigned long int
2549 pipe_exit_routine(pTHX)
2550 {
2551     pInfo info;
2552     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2553     int sts, did_stuff, need_eof, j;
2554
2555     /*
2556         flush any pending i/o
2557     */
2558     info = open_pipes;
2559     while (info) {
2560         if (info->fp) {
2561            if (!info->useFILE)
2562                PerlIO_flush(info->fp);   /* first, flush data */
2563            else
2564                fflush((FILE *)info->fp);
2565         }
2566         info = info->next;
2567     }
2568
2569     /*
2570      next we try sending an EOF...ignore if doesn't work, make sure we
2571      don't hang
2572     */
2573     did_stuff = 0;
2574     info = open_pipes;
2575
2576     while (info) {
2577       int need_eof;
2578       _ckvmssts_noperl(sys$setast(0));
2579       if (info->in && !info->in->shut_on_empty) {
2580         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2581                           0, 0, 0, 0, 0, 0));
2582         info->waiting = 1;
2583         did_stuff = 1;
2584       }
2585       _ckvmssts_noperl(sys$setast(1));
2586       info = info->next;
2587     }
2588
2589     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2590
2591     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2592         int nwait = 0;
2593
2594         info = open_pipes;
2595         while (info) {
2596           _ckvmssts_noperl(sys$setast(0));
2597           if (info->waiting && info->done)
2598                 info->waiting = 0;
2599           nwait += info->waiting;
2600           _ckvmssts_noperl(sys$setast(1));
2601           info = info->next;
2602         }
2603         if (!nwait) break;
2604         sleep(1);
2605     }
2606
2607     did_stuff = 0;
2608     info = open_pipes;
2609     while (info) {
2610       _ckvmssts_noperl(sys$setast(0));
2611       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2612         sts = sys$forcex(&info->pid,0,&abort);
2613         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2614         did_stuff = 1;
2615       }
2616       _ckvmssts_noperl(sys$setast(1));
2617       info = info->next;
2618     }
2619
2620     /* again, wait for effect */
2621
2622     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2623         int nwait = 0;
2624
2625         info = open_pipes;
2626         while (info) {
2627           _ckvmssts_noperl(sys$setast(0));
2628           if (info->waiting && info->done)
2629                 info->waiting = 0;
2630           nwait += info->waiting;
2631           _ckvmssts_noperl(sys$setast(1));
2632           info = info->next;
2633         }
2634         if (!nwait) break;
2635         sleep(1);
2636     }
2637
2638     info = open_pipes;
2639     while (info) {
2640       _ckvmssts_noperl(sys$setast(0));
2641       if (!info->done) {  /* We tried to be nice . . . */
2642         sts = sys$delprc(&info->pid,0);
2643         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2644       }
2645       _ckvmssts_noperl(sys$setast(1));
2646       info = info->next;
2647     }
2648
2649     while(open_pipes) {
2650       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2651       else if (!(sts & 1)) retsts = sts;
2652     }
2653     return retsts;
2654 }
2655
2656 static struct exit_control_block pipe_exitblock =
2657        {(struct exit_control_block *) 0,
2658         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2659
2660 static void pipe_mbxtofd_ast(pPipe p);
2661 static void pipe_tochild1_ast(pPipe p);
2662 static void pipe_tochild2_ast(pPipe p);
2663
2664 static void
2665 popen_completion_ast(pInfo info)
2666 {
2667   pInfo i = open_pipes;
2668   int iss;
2669   int sts;
2670   pXpipe x;
2671
2672   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2673   closed_list[closed_index].pid = info->pid;
2674   closed_list[closed_index].completion = info->completion;
2675   closed_index++;
2676   if (closed_index == NKEEPCLOSED)
2677     closed_index = 0;
2678   closed_num++;
2679
2680   while (i) {
2681     if (i == info) break;
2682     i = i->next;
2683   }
2684   if (!i) return;       /* unlinked, probably freed too */
2685
2686   info->done = TRUE;
2687
2688 /*
2689     Writing to subprocess ...
2690             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2691
2692             chan_out may be waiting for "done" flag, or hung waiting
2693             for i/o completion to child...cancel the i/o.  This will
2694             put it into "snarf mode" (done but no EOF yet) that discards
2695             input.
2696
2697     Output from subprocess (stdout, stderr) needs to be flushed and
2698     shut down.   We try sending an EOF, but if the mbx is full the pipe
2699     routine should still catch the "shut_on_empty" flag, telling it to
2700     use immediate-style reads so that "mbx empty" -> EOF.
2701
2702
2703 */
2704   if (info->in && !info->in_done) {               /* only for mode=w */
2705         if (info->in->shut_on_empty && info->in->need_wake) {
2706             info->in->need_wake = FALSE;
2707             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2708         } else {
2709             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2710         }
2711   }
2712
2713   if (info->out && !info->out_done) {             /* were we also piping output? */
2714       info->out->shut_on_empty = TRUE;
2715       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2716       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2717       _ckvmssts_noperl(iss);
2718   }
2719
2720   if (info->err && !info->err_done) {        /* we were piping stderr */
2721         info->err->shut_on_empty = TRUE;
2722         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2723         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2724         _ckvmssts_noperl(iss);
2725   }
2726   _ckvmssts_noperl(sys$setef(pipe_ef));
2727
2728 }
2729
2730 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2731 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2732
2733 /*
2734     we actually differ from vmstrnenv since we use this to
2735     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2736     are pointing to the same thing
2737 */
2738
2739 static unsigned short
2740 popen_translate(pTHX_ char *logical, char *result)
2741 {
2742     int iss;
2743     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2744     $DESCRIPTOR(d_log,"");
2745     struct _il3 {
2746         unsigned short length;
2747         unsigned short code;
2748         char *         buffer_addr;
2749         unsigned short *retlenaddr;
2750     } itmlst[2];
2751     unsigned short l, ifi;
2752
2753     d_log.dsc$a_pointer = logical;
2754     d_log.dsc$w_length  = strlen(logical);
2755
2756     itmlst[0].code = LNM$_STRING;
2757     itmlst[0].length = 255;
2758     itmlst[0].buffer_addr = result;
2759     itmlst[0].retlenaddr = &l;
2760
2761     itmlst[1].code = 0;
2762     itmlst[1].length = 0;
2763     itmlst[1].buffer_addr = 0;
2764     itmlst[1].retlenaddr = 0;
2765
2766     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2767     if (iss == SS$_NOLOGNAM) {
2768         iss = SS$_NORMAL;
2769         l = 0;
2770     }
2771     if (!(iss&1)) lib$signal(iss);
2772     result[l] = '\0';
2773 /*
2774     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
2775     strip it off and return the ifi, if any
2776 */
2777     ifi  = 0;
2778     if (result[0] == 0x1b && result[1] == 0x00) {
2779         memmove(&ifi,result+2,2);
2780         strcpy(result,result+4);
2781     }
2782     return ifi;     /* this is the RMS internal file id */
2783 }
2784
2785 static void pipe_infromchild_ast(pPipe p);
2786
2787 /*
2788     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2789     inside an AST routine without worrying about reentrancy and which Perl
2790     memory allocator is being used.
2791
2792     We read data and queue up the buffers, then spit them out one at a
2793     time to the output mailbox when the output mailbox is ready for one.
2794
2795 */
2796 #define INITIAL_TOCHILDQUEUE  2
2797
2798 static pPipe
2799 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2800 {
2801     pPipe p;
2802     pCBuf b;
2803     char mbx1[64], mbx2[64];
2804     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2805                                       DSC$K_CLASS_S, mbx1},
2806                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2807                                       DSC$K_CLASS_S, mbx2};
2808     unsigned int dviitm = DVI$_DEVBUFSIZ;
2809     int j, n;
2810
2811     n = sizeof(Pipe);
2812     _ckvmssts(lib$get_vm(&n, &p));
2813
2814     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2815     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2816     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2817
2818     p->buf           = 0;
2819     p->shut_on_empty = FALSE;
2820     p->need_wake     = FALSE;
2821     p->type          = 0;
2822     p->retry         = 0;
2823     p->iosb.status   = SS$_NORMAL;
2824     p->iosb2.status  = SS$_NORMAL;
2825     p->free          = RQE_ZERO;
2826     p->wait          = RQE_ZERO;
2827     p->curr          = 0;
2828     p->curr2         = 0;
2829     p->info          = 0;
2830 #ifdef PERL_IMPLICIT_CONTEXT
2831     p->thx           = aTHX;
2832 #endif
2833
2834     n = sizeof(CBuf) + p->bufsize;
2835
2836     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2837         _ckvmssts(lib$get_vm(&n, &b));
2838         b->buf = (char *) b + sizeof(CBuf);
2839         _ckvmssts(lib$insqhi(b, &p->free));
2840     }
2841
2842     pipe_tochild2_ast(p);
2843     pipe_tochild1_ast(p);
2844     strcpy(wmbx, mbx1);
2845     strcpy(rmbx, mbx2);
2846     return p;
2847 }
2848
2849 /*  reads the MBX Perl is writing, and queues */
2850
2851 static void
2852 pipe_tochild1_ast(pPipe p)
2853 {
2854     pCBuf b = p->curr;
2855     int iss = p->iosb.status;
2856     int eof = (iss == SS$_ENDOFFILE);
2857     int sts;
2858 #ifdef PERL_IMPLICIT_CONTEXT
2859     pTHX = p->thx;
2860 #endif
2861
2862     if (p->retry) {
2863         if (eof) {
2864             p->shut_on_empty = TRUE;
2865             b->eof     = TRUE;
2866             _ckvmssts(sys$dassgn(p->chan_in));
2867         } else  {
2868             _ckvmssts(iss);
2869         }
2870
2871         b->eof  = eof;
2872         b->size = p->iosb.count;
2873         _ckvmssts(sts = lib$insqhi(b, &p->wait));
2874         if (p->need_wake) {
2875             p->need_wake = FALSE;
2876             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2877         }
2878     } else {
2879         p->retry = 1;   /* initial call */
2880     }
2881
2882     if (eof) {                  /* flush the free queue, return when done */
2883         int n = sizeof(CBuf) + p->bufsize;
2884         while (1) {
2885             iss = lib$remqti(&p->free, &b);
2886             if (iss == LIB$_QUEWASEMP) return;
2887             _ckvmssts(iss);
2888             _ckvmssts(lib$free_vm(&n, &b));
2889         }
2890     }
2891
2892     iss = lib$remqti(&p->free, &b);
2893     if (iss == LIB$_QUEWASEMP) {
2894         int n = sizeof(CBuf) + p->bufsize;
2895         _ckvmssts(lib$get_vm(&n, &b));
2896         b->buf = (char *) b + sizeof(CBuf);
2897     } else {
2898        _ckvmssts(iss);
2899     }
2900
2901     p->curr = b;
2902     iss = sys$qio(0,p->chan_in,
2903              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2904              &p->iosb,
2905              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2906     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2907     _ckvmssts(iss);
2908 }
2909
2910
2911 /* writes queued buffers to output, waits for each to complete before
2912    doing the next */
2913
2914 static void
2915 pipe_tochild2_ast(pPipe p)
2916 {
2917     pCBuf b = p->curr2;
2918     int iss = p->iosb2.status;
2919     int n = sizeof(CBuf) + p->bufsize;
2920     int done = (p->info && p->info->done) ||
2921               iss == SS$_CANCEL || iss == SS$_ABORT;
2922 #if defined(PERL_IMPLICIT_CONTEXT)
2923     pTHX = p->thx;
2924 #endif
2925
2926     do {
2927         if (p->type) {         /* type=1 has old buffer, dispose */
2928             if (p->shut_on_empty) {
2929                 _ckvmssts(lib$free_vm(&n, &b));
2930             } else {
2931                 _ckvmssts(lib$insqhi(b, &p->free));
2932             }
2933             p->type = 0;
2934         }
2935
2936         iss = lib$remqti(&p->wait, &b);
2937         if (iss == LIB$_QUEWASEMP) {
2938             if (p->shut_on_empty) {
2939                 if (done) {
2940                     _ckvmssts(sys$dassgn(p->chan_out));
2941                     *p->pipe_done = TRUE;
2942                     _ckvmssts(sys$setef(pipe_ef));
2943                 } else {
2944                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2945                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2946                 }
2947                 return;
2948             }
2949             p->need_wake = TRUE;
2950             return;
2951         }
2952         _ckvmssts(iss);
2953         p->type = 1;
2954     } while (done);
2955
2956
2957     p->curr2 = b;
2958     if (b->eof) {
2959         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2960             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2961     } else {
2962         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2963             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2964     }
2965
2966     return;
2967
2968 }
2969
2970
2971 static pPipe
2972 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2973 {
2974     pPipe p;
2975     char mbx1[64], mbx2[64];
2976     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2977                                       DSC$K_CLASS_S, mbx1},
2978                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2979                                       DSC$K_CLASS_S, mbx2};
2980     unsigned int dviitm = DVI$_DEVBUFSIZ;
2981
2982     int n = sizeof(Pipe);
2983     _ckvmssts(lib$get_vm(&n, &p));
2984     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2985     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2986
2987     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2988     n = p->bufsize * sizeof(char);
2989     _ckvmssts(lib$get_vm(&n, &p->buf));
2990     p->shut_on_empty = FALSE;
2991     p->info   = 0;
2992     p->type   = 0;
2993     p->iosb.status = SS$_NORMAL;
2994 #if defined(PERL_IMPLICIT_CONTEXT)
2995     p->thx = aTHX;
2996 #endif
2997     pipe_infromchild_ast(p);
2998
2999     strcpy(wmbx, mbx1);
3000     strcpy(rmbx, mbx2);
3001     return p;
3002 }
3003
3004 static void
3005 pipe_infromchild_ast(pPipe p)
3006 {
3007     int iss = p->iosb.status;
3008     int eof = (iss == SS$_ENDOFFILE);
3009     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3010     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3011 #if defined(PERL_IMPLICIT_CONTEXT)
3012     pTHX = p->thx;
3013 #endif
3014
3015     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3016         _ckvmssts(sys$dassgn(p->chan_out));
3017         p->chan_out = 0;
3018     }
3019
3020     /* read completed:
3021             input shutdown if EOF from self (done or shut_on_empty)
3022             output shutdown if closing flag set (my_pclose)
3023             send data/eof from child or eof from self
3024             otherwise, re-read (snarf of data from child)
3025     */
3026
3027     if (p->type == 1) {
3028         p->type = 0;
3029         if (myeof && p->chan_in) {                  /* input shutdown */
3030             _ckvmssts(sys$dassgn(p->chan_in));
3031             p->chan_in = 0;
3032         }
3033
3034         if (p->chan_out) {
3035             if (myeof || kideof) {      /* pass EOF to parent */
3036                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3037                               pipe_infromchild_ast, p,
3038                               0, 0, 0, 0, 0, 0));
3039                 return;
3040             } else if (eof) {       /* eat EOF --- fall through to read*/
3041
3042             } else {                /* transmit data */
3043                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3044                               pipe_infromchild_ast,p,
3045                               p->buf, p->iosb.count, 0, 0, 0, 0));
3046                 return;
3047             }
3048         }
3049     }
3050
3051     /*  everything shut? flag as done */
3052
3053     if (!p->chan_in && !p->chan_out) {
3054         *p->pipe_done = TRUE;
3055         _ckvmssts(sys$setef(pipe_ef));
3056         return;
3057     }
3058
3059     /* write completed (or read, if snarfing from child)
3060             if still have input active,
3061                queue read...immediate mode if shut_on_empty so we get EOF if empty
3062             otherwise,
3063                check if Perl reading, generate EOFs as needed
3064     */
3065
3066     if (p->type == 0) {
3067         p->type = 1;
3068         if (p->chan_in) {
3069             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3070                           pipe_infromchild_ast,p,
3071                           p->buf, p->bufsize, 0, 0, 0, 0);
3072             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3073             _ckvmssts(iss);
3074         } else {           /* send EOFs for extra reads */
3075             p->iosb.status = SS$_ENDOFFILE;
3076             p->iosb.dvispec = 0;
3077             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3078                       0, 0, 0,
3079                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3080         }
3081     }
3082 }
3083
3084 static pPipe
3085 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3086 {
3087     pPipe p;
3088     char mbx[64];
3089     unsigned long dviitm = DVI$_DEVBUFSIZ;
3090     struct stat s;
3091     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3092                                       DSC$K_CLASS_S, mbx};
3093     int n = sizeof(Pipe);
3094
3095     /* things like terminals and mbx's don't need this filter */
3096     if (fd && fstat(fd,&s) == 0) {
3097         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3098         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
3099                                          DSC$K_CLASS_S, s.st_dev};
3100
3101         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
3102         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
3103             strcpy(out, s.st_dev);
3104             return 0;
3105         }
3106     }
3107
3108     _ckvmssts(lib$get_vm(&n, &p));
3109     p->fd_out = dup(fd);
3110     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3111     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3112     n = (p->bufsize+1) * sizeof(char);
3113     _ckvmssts(lib$get_vm(&n, &p->buf));
3114     p->shut_on_empty = FALSE;
3115     p->retry = 0;
3116     p->info  = 0;
3117     strcpy(out, mbx);
3118
3119     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3120                   pipe_mbxtofd_ast, p,
3121                   p->buf, p->bufsize, 0, 0, 0, 0));
3122
3123     return p;
3124 }
3125
3126 static void
3127 pipe_mbxtofd_ast(pPipe p)
3128 {
3129     int iss = p->iosb.status;
3130     int done = p->info->done;
3131     int iss2;
3132     int eof = (iss == SS$_ENDOFFILE);
3133     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3134     int err = !(iss&1) && !eof;
3135 #if defined(PERL_IMPLICIT_CONTEXT)
3136     pTHX = p->thx;
3137 #endif
3138
3139     if (done && myeof) {               /* end piping */
3140         close(p->fd_out);
3141         sys$dassgn(p->chan_in);
3142         *p->pipe_done = TRUE;
3143         _ckvmssts(sys$setef(pipe_ef));
3144         return;
3145     }
3146
3147     if (!err && !eof) {             /* good data to send to file */
3148         p->buf[p->iosb.count] = '\n';
3149         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3150         if (iss2 < 0) {
3151             p->retry++;
3152             if (p->retry < MAX_RETRY) {
3153                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3154                 return;
3155             }
3156         }
3157         p->retry = 0;
3158     } else if (err) {
3159         _ckvmssts(iss);
3160     }
3161
3162
3163     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3164           pipe_mbxtofd_ast, p,
3165           p->buf, p->bufsize, 0, 0, 0, 0);
3166     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3167     _ckvmssts(iss);
3168 }
3169
3170
3171 typedef struct _pipeloc     PLOC;
3172 typedef struct _pipeloc*   pPLOC;
3173
3174 struct _pipeloc {
3175     pPLOC   next;
3176     char    dir[NAM$C_MAXRSS+1];
3177 };
3178 static pPLOC  head_PLOC = 0;
3179
3180 void
3181 free_pipelocs(pTHX_ void *head)
3182 {
3183     pPLOC p, pnext;
3184     pPLOC *pHead = (pPLOC *)head;
3185
3186     p = *pHead;
3187     while (p) {
3188         pnext = p->next;
3189         PerlMem_free(p);
3190         p = pnext;
3191     }
3192     *pHead = 0;
3193 }
3194
3195 static void
3196 store_pipelocs(pTHX)
3197 {
3198     int    i;
3199     pPLOC  p;
3200     AV    *av = 0;
3201     SV    *dirsv;
3202     GV    *gv;
3203     char  *dir, *x;
3204     char  *unixdir;
3205     char  temp[NAM$C_MAXRSS+1];
3206     STRLEN n_a;
3207
3208     if (head_PLOC)
3209         free_pipelocs(aTHX_ &head_PLOC);
3210
3211 /*  the . directory from @INC comes last */
3212
3213     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3214     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3215     p->next = head_PLOC;
3216     head_PLOC = p;
3217     strcpy(p->dir,"./");
3218
3219 /*  get the directory from $^X */
3220
3221     unixdir = PerlMem_malloc(VMS_MAXRSS);
3222     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3223
3224 #ifdef PERL_IMPLICIT_CONTEXT
3225     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3226 #else
3227     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3228 #endif
3229         strcpy(temp, PL_origargv[0]);
3230         x = strrchr(temp,']');
3231         if (x == NULL) {
3232         x = strrchr(temp,'>');
3233           if (x == NULL) {
3234             /* It could be a UNIX path */
3235             x = strrchr(temp,'/');
3236           }
3237         }
3238         if (x)
3239           x[1] = '\0';
3240         else {
3241           /* Got a bare name, so use default directory */
3242           temp[0] = '.';
3243           temp[1] = '\0';
3244         }
3245
3246         if ((tounixpath(temp, unixdir)) != Nullch) {
3247             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3248             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3249             p->next = head_PLOC;
3250             head_PLOC = p;
3251             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3252             p->dir[NAM$C_MAXRSS] = '\0';
3253         }
3254     }
3255
3256 /*  reverse order of @INC entries, skip "." since entered above */
3257
3258 #ifdef PERL_IMPLICIT_CONTEXT
3259     if (aTHX)
3260 #endif
3261     if (PL_incgv) av = GvAVn(PL_incgv);
3262
3263     for (i = 0; av && i <= AvFILL(av); i++) {
3264         dirsv = *av_fetch(av,i,TRUE);
3265
3266         if (SvROK(dirsv)) continue;
3267         dir = SvPVx(dirsv,n_a);
3268         if (strcmp(dir,".") == 0) continue;
3269         if ((tounixpath(dir, unixdir)) == Nullch)
3270             continue;
3271
3272         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3273         p->next = head_PLOC;
3274         head_PLOC = p;
3275         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3276         p->dir[NAM$C_MAXRSS] = '\0';
3277     }
3278
3279 /* most likely spot (ARCHLIB) put first in the list */
3280
3281 #ifdef ARCHLIB_EXP
3282     if ((tounixpath(ARCHLIB_EXP, unixdir)) != Nullch) {
3283         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3284         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3285         p->next = head_PLOC;
3286         head_PLOC = p;
3287         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3288         p->dir[NAM$C_MAXRSS] = '\0';
3289     }
3290 #endif
3291     PerlMem_free(unixdir);
3292 }
3293
3294
3295 static char *
3296 find_vmspipe(pTHX)
3297 {
3298     static int   vmspipe_file_status = 0;
3299     static char  vmspipe_file[NAM$C_MAXRSS+1];
3300
3301     /* already found? Check and use ... need read+execute permission */
3302
3303     if (vmspipe_file_status == 1) {
3304         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3305          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3306             return vmspipe_file;
3307         }
3308         vmspipe_file_status = 0;
3309     }
3310
3311     /* scan through stored @INC, $^X */
3312
3313     if (vmspipe_file_status == 0) {
3314         char file[NAM$C_MAXRSS+1];
3315         pPLOC  p = head_PLOC;
3316
3317         while (p) {
3318             char * exp_res;
3319             strcpy(file, p->dir);
3320             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3321             file[NAM$C_MAXRSS] = '\0';
3322             p = p->next;
3323
3324             exp_res = do_rmsexpand
3325                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS);
3326             if (!exp_res) continue;
3327
3328             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3329              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3330                 vmspipe_file_status = 1;
3331                 return vmspipe_file;
3332             }
3333         }
3334         vmspipe_file_status = -1;   /* failed, use tempfiles */
3335     }
3336
3337     return 0;
3338 }
3339
3340 static FILE *
3341 vmspipe_tempfile(pTHX)
3342 {
3343     char file[NAM$C_MAXRSS+1];
3344     FILE *fp;
3345     static int index = 0;
3346     Stat_t s0, s1;
3347     int cmp_result;
3348
3349     /* create a tempfile */
3350
3351     /* we can't go from   W, shr=get to  R, shr=get without
3352        an intermediate vulnerable state, so don't bother trying...
3353
3354        and lib$spawn doesn't shr=put, so have to close the write
3355
3356        So... match up the creation date/time and the FID to
3357        make sure we're dealing with the same file
3358
3359     */
3360
3361     index++;
3362     if (!decc_filename_unix_only) {
3363       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3364       fp = fopen(file,"w");
3365       if (!fp) {
3366         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3367         fp = fopen(file,"w");
3368         if (!fp) {
3369             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3370             fp = fopen(file,"w");
3371         }
3372       }
3373      }
3374      else {
3375       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3376       fp = fopen(file,"w");
3377       if (!fp) {
3378         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3379         fp = fopen(file,"w");
3380         if (!fp) {
3381           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3382           fp = fopen(file,"w");
3383         }
3384       }
3385     }
3386     if (!fp) return 0;  /* we're hosed */
3387
3388     fprintf(fp,"$! 'f$verify(0)'\n");
3389     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3390     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3391     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3392     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3393     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3394     fprintf(fp,"$ perl_del    = \"delete\"\n");
3395     fprintf(fp,"$ pif         = \"if\"\n");
3396     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3397     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3398     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3399     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3400     fprintf(fp,"$!  --- build command line to get max possible length\n");
3401     fprintf(fp,"$c=perl_popen_cmd0\n");
3402     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3403     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3404     fprintf(fp,"$x=perl_popen_cmd3\n");
3405     fprintf(fp,"$c=c+x\n");
3406     fprintf(fp,"$ perl_on\n");
3407     fprintf(fp,"$ 'c'\n");
3408     fprintf(fp,"$ perl_status = $STATUS\n");
3409     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3410     fprintf(fp,"$ perl_exit 'perl_status'\n");
3411     fsync(fileno(fp));
3412
3413     fgetname(fp, file, 1);
3414     fstat(fileno(fp), (struct stat *)&s0);
3415     fclose(fp);
3416
3417     if (decc_filename_unix_only)
3418         do_tounixspec(file, file, 0);
3419     fp = fopen(file,"r","shr=get");
3420     if (!fp) return 0;
3421     fstat(fileno(fp), (struct stat *)&s1);
3422
3423     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3424     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3425         fclose(fp);
3426         return 0;
3427     }
3428
3429     return fp;
3430 }
3431
3432
3433
3434 static PerlIO *
3435 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3436 {
3437     static int handler_set_up = FALSE;
3438     unsigned long int sts, flags = CLI$M_NOWAIT;
3439     /* The use of a GLOBAL table (as was done previously) rendered
3440      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3441      * environment.  Hence we've switched to LOCAL symbol table.
3442      */
3443     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3444     int j, wait = 0, n;
3445     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3446     char in[512], out[512], err[512], mbx[512];
3447     FILE *tpipe = 0;
3448     char tfilebuf[NAM$C_MAXRSS+1];
3449     pInfo info = NULL;
3450     char cmd_sym_name[20];
3451     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3452                                       DSC$K_CLASS_S, symbol};
3453     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3454                                       DSC$K_CLASS_S, 0};
3455     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3456                                       DSC$K_CLASS_S, cmd_sym_name};
3457     struct dsc$descriptor_s *vmscmd;
3458     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3459     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3460     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3461
3462     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3463
3464     /* once-per-program initialization...
3465        note that the SETAST calls and the dual test of pipe_ef
3466        makes sure that only the FIRST thread through here does
3467        the initialization...all other threads wait until it's
3468        done.
3469
3470        Yeah, uglier than a pthread call, it's got all the stuff inline
3471        rather than in a separate routine.
3472     */
3473
3474     if (!pipe_ef) {
3475         _ckvmssts(sys$setast(0));
3476         if (!pipe_ef) {
3477             unsigned long int pidcode = JPI$_PID;
3478             $DESCRIPTOR(d_delay, RETRY_DELAY);
3479             _ckvmssts(lib$get_ef(&pipe_ef));
3480             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3481             _ckvmssts(sys$bintim(&d_delay, delaytime));
3482         }
3483         if (!handler_set_up) {
3484           _ckvmssts(sys$dclexh(&pipe_exitblock));
3485           handler_set_up = TRUE;
3486         }
3487         _ckvmssts(sys$setast(1));
3488     }
3489
3490     /* see if we can find a VMSPIPE.COM */
3491
3492     tfilebuf[0] = '@';
3493     vmspipe = find_vmspipe(aTHX);
3494     if (vmspipe) {
3495         strcpy(tfilebuf+1,vmspipe);
3496     } else {        /* uh, oh...we're in tempfile hell */
3497         tpipe = vmspipe_tempfile(aTHX);
3498         if (!tpipe) {       /* a fish popular in Boston */
3499             if (ckWARN(WARN_PIPE)) {
3500                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3501             }
3502         return Nullfp;
3503         }
3504         fgetname(tpipe,tfilebuf+1,1);
3505     }
3506     vmspipedsc.dsc$a_pointer = tfilebuf;
3507     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3508
3509     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3510     if (!(sts & 1)) {
3511       switch (sts) {
3512         case RMS$_FNF:  case RMS$_DNF:
3513           set_errno(ENOENT); break;
3514         case RMS$_DIR:
3515           set_errno(ENOTDIR); break;
3516         case RMS$_DEV:
3517           set_errno(ENODEV); break;
3518         case RMS$_PRV:
3519           set_errno(EACCES); break;
3520         case RMS$_SYN:
3521           set_errno(EINVAL); break;
3522         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3523           set_errno(E2BIG); break;
3524         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3525           _ckvmssts(sts); /* fall through */
3526         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3527           set_errno(EVMSERR);
3528       }
3529       set_vaxc_errno(sts);
3530       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3531         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3532       }
3533       *psts = sts;
3534       return Nullfp;
3535     }
3536     n = sizeof(Info);
3537     _ckvmssts(lib$get_vm(&n, &info));
3538
3539     strcpy(mode,in_mode);
3540     info->mode = *mode;
3541     info->done = FALSE;
3542     info->completion = 0;
3543     info->closing    = FALSE;
3544     info->in         = 0;
3545     info->out        = 0;
3546     info->err        = 0;
3547     info->fp         = Nullfp;
3548     info->useFILE    = 0;
3549     info->waiting    = 0;
3550     info->in_done    = TRUE;
3551     info->out_done   = TRUE;
3552     info->err_done   = TRUE;
3553     in[0] = out[0] = err[0] = '\0';
3554
3555     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3556         info->useFILE = 1;
3557         strcpy(p,p+1);
3558     }
3559     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3560         wait = 1;
3561         strcpy(p,p+1);
3562     }
3563
3564     if (*mode == 'r') {             /* piping from subroutine */
3565
3566         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3567         if (info->out) {
3568             info->out->pipe_done = &info->out_done;
3569             info->out_done = FALSE;
3570             info->out->info = info;
3571         }
3572         if (!info->useFILE) {
3573         info->fp  = PerlIO_open(mbx, mode);
3574         } else {
3575             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3576             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3577         }
3578
3579         if (!info->fp && info->out) {
3580             sys$cancel(info->out->chan_out);
3581
3582             while (!info->out_done) {
3583                 int done;
3584                 _ckvmssts(sys$setast(0));
3585                 done = info->out_done;
3586                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3587                 _ckvmssts(sys$setast(1));
3588                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3589             }
3590
3591             if (info->out->buf) {
3592                 n = info->out->bufsize * sizeof(char);
3593                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3594             }
3595             n = sizeof(Pipe);
3596             _ckvmssts(lib$free_vm(&n, &info->out));
3597             n = sizeof(Info);
3598             _ckvmssts(lib$free_vm(&n, &info));
3599             *psts = RMS$_FNF;
3600             return Nullfp;
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     } else if (*mode == 'w') {      /* piping to subroutine */
3611
3612         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3613         if (info->out) {
3614             info->out->pipe_done = &info->out_done;
3615             info->out_done = FALSE;
3616             info->out->info = info;
3617         }
3618
3619         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3620         if (info->err) {
3621             info->err->pipe_done = &info->err_done;
3622             info->err_done = FALSE;
3623             info->err->info = info;
3624         }
3625
3626         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3627         if (!info->useFILE) {
3628             info->fp  = PerlIO_open(mbx, mode);
3629         } else {
3630             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3631             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3632         }
3633
3634         if (info->in) {
3635             info->in->pipe_done = &info->in_done;
3636             info->in_done = FALSE;
3637             info->in->info = info;
3638         }
3639
3640         /* error cleanup */
3641         if (!info->fp && info->in) {
3642             info->done = TRUE;
3643             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3644                               0, 0, 0, 0, 0, 0, 0, 0));
3645
3646             while (!info->in_done) {
3647                 int done;
3648                 _ckvmssts(sys$setast(0));
3649                 done = info->in_done;
3650                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3651                 _ckvmssts(sys$setast(1));
3652                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3653             }
3654
3655             if (info->in->buf) {
3656                 n = info->in->bufsize * sizeof(char);
3657                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3658             }
3659             n = sizeof(Pipe);
3660             _ckvmssts(lib$free_vm(&n, &info->in));
3661             n = sizeof(Info);
3662             _ckvmssts(lib$free_vm(&n, &info));
3663             *psts = RMS$_FNF;
3664             return Nullfp;
3665         }
3666
3667
3668     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3669         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3670         if (info->out) {
3671             info->out->pipe_done = &info->out_done;
3672             info->out_done = FALSE;
3673             info->out->info = info;
3674         }
3675
3676         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3677         if (info->err) {
3678             info->err->pipe_done = &info->err_done;
3679             info->err_done = FALSE;
3680             info->err->info = info;
3681         }
3682     }
3683
3684     symbol[MAX_DCL_SYMBOL] = '\0';
3685
3686     strncpy(symbol, in, MAX_DCL_SYMBOL);
3687     d_symbol.dsc$w_length = strlen(symbol);
3688     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3689
3690     strncpy(symbol, err, MAX_DCL_SYMBOL);
3691     d_symbol.dsc$w_length = strlen(symbol);
3692     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3693
3694     strncpy(symbol, out, MAX_DCL_SYMBOL);
3695     d_symbol.dsc$w_length = strlen(symbol);
3696     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3697
3698     p = vmscmd->dsc$a_pointer;
3699     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
3700     if (*p == '$') p++;                         /* remove leading $ */
3701     while (*p == ' ' || *p == '\t') p++;
3702
3703     for (j = 0; j < 4; j++) {
3704         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3705         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3706
3707     strncpy(symbol, p, MAX_DCL_SYMBOL);
3708     d_symbol.dsc$w_length = strlen(symbol);
3709     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3710
3711         if (strlen(p) > MAX_DCL_SYMBOL) {
3712             p += MAX_DCL_SYMBOL;
3713         } else {
3714             p += strlen(p);
3715         }
3716     }
3717     _ckvmssts(sys$setast(0));
3718     info->next=open_pipes;  /* prepend to list */
3719     open_pipes=info;
3720     _ckvmssts(sys$setast(1));
3721     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3722      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
3723      * have SYS$COMMAND if we need it.
3724      */
3725     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3726                       0, &info->pid, &info->completion,
3727                       0, popen_completion_ast,info,0,0,0));
3728
3729     /* if we were using a tempfile, close it now */
3730
3731     if (tpipe) fclose(tpipe);
3732
3733     /* once the subprocess is spawned, it has copied the symbols and
3734        we can get rid of ours */
3735
3736     for (j = 0; j < 4; j++) {
3737         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3738         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3739     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3740     }
3741     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
3742     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3743     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3744     vms_execfree(vmscmd);
3745
3746 #ifdef PERL_IMPLICIT_CONTEXT
3747     if (aTHX)
3748 #endif
3749     PL_forkprocess = info->pid;
3750
3751     if (wait) {
3752          int done = 0;
3753          while (!done) {
3754              _ckvmssts(sys$setast(0));
3755              done = info->done;
3756              if (!done) _ckvmssts(sys$clref(pipe_ef));
3757              _ckvmssts(sys$setast(1));
3758              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3759          }
3760         *psts = info->completion;
3761 /* Caller thinks it is open and tries to close it. */
3762 /* This causes some problems, as it changes the error status */
3763 /*        my_pclose(info->fp); */
3764     } else {
3765         *psts = SS$_NORMAL;
3766     }
3767     return info->fp;
3768 }  /* end of safe_popen */
3769
3770
3771 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
3772 PerlIO *
3773 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3774 {
3775     int sts;
3776     TAINT_ENV();
3777     TAINT_PROPER("popen");
3778     PERL_FLUSHALL_FOR_CHILD;
3779     return safe_popen(aTHX_ cmd,mode,&sts);
3780 }
3781
3782 /*}}}*/
3783
3784 /*{{{  I32 my_pclose(PerlIO *fp)*/
3785 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3786 {
3787     pInfo info, last = NULL;
3788     unsigned long int retsts;
3789     int done, iss, n;
3790
3791     for (info = open_pipes; info != NULL; last = info, info = info->next)
3792         if (info->fp == fp) break;
3793
3794     if (info == NULL) {  /* no such pipe open */
3795       set_errno(ECHILD); /* quoth POSIX */
3796       set_vaxc_errno(SS$_NONEXPR);
3797       return -1;
3798     }
3799
3800     /* If we were writing to a subprocess, insure that someone reading from
3801      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
3802      * produce an EOF record in the mailbox.
3803      *
3804      *  well, at least sometimes it *does*, so we have to watch out for
3805      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
3806      */
3807      if (info->fp) {
3808         if (!info->useFILE)
3809             PerlIO_flush(info->fp);   /* first, flush data */
3810         else
3811             fflush((FILE *)info->fp);
3812     }
3813
3814     _ckvmssts(sys$setast(0));
3815      info->closing = TRUE;
3816      done = info->done && info->in_done && info->out_done && info->err_done;
3817      /* hanging on write to Perl's input? cancel it */
3818      if (info->mode == 'r' && info->out && !info->out_done) {
3819         if (info->out->chan_out) {
3820             _ckvmssts(sys$cancel(info->out->chan_out));
3821             if (!info->out->chan_in) {   /* EOF generation, need AST */
3822                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3823             }
3824         }
3825      }
3826      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
3827          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3828                            0, 0, 0, 0, 0, 0));
3829     _ckvmssts(sys$setast(1));
3830     if (info->fp) {
3831      if (!info->useFILE)
3832         PerlIO_close(info->fp);
3833      else
3834         fclose((FILE *)info->fp);
3835     }
3836      /*
3837         we have to wait until subprocess completes, but ALSO wait until all
3838         the i/o completes...otherwise we'll be freeing the "info" structure
3839         that the i/o ASTs could still be using...
3840      */
3841
3842      while (!done) {
3843          _ckvmssts(sys$setast(0));
3844          done = info->done && info->in_done && info->out_done && info->err_done;
3845          if (!done) _ckvmssts(sys$clref(pipe_ef));
3846          _ckvmssts(sys$setast(1));
3847          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3848      }
3849      retsts = info->completion;
3850
3851     /* remove from list of open pipes */
3852     _ckvmssts(sys$setast(0));
3853     if (last) last->next = info->next;
3854     else open_pipes = info->next;
3855     _ckvmssts(sys$setast(1));
3856
3857     /* free buffers and structures */
3858
3859     if (info->in) {
3860         if (info->in->buf) {
3861             n = info->in->bufsize * sizeof(char);
3862             _ckvmssts(lib$free_vm(&n, &info->in->buf));
3863         }
3864         n = sizeof(Pipe);
3865         _ckvmssts(lib$free_vm(&n, &info->in));
3866     }
3867     if (info->out) {
3868         if (info->out->buf) {
3869             n = info->out->bufsize * sizeof(char);
3870             _ckvmssts(lib$free_vm(&n, &info->out->buf));
3871         }
3872         n = sizeof(Pipe);
3873         _ckvmssts(lib$free_vm(&n, &info->out));
3874     }
3875     if (info->err) {
3876         if (info->err->buf) {
3877             n = info->err->bufsize * sizeof(char);
3878             _ckvmssts(lib$free_vm(&n, &info->err->buf));
3879         }
3880         n = sizeof(Pipe);
3881         _ckvmssts(lib$free_vm(&n, &info->err));
3882     }
3883     n = sizeof(Info);
3884     _ckvmssts(lib$free_vm(&n, &info));
3885
3886     return retsts;
3887
3888 }  /* end of my_pclose() */
3889
3890 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3891   /* Roll our own prototype because we want this regardless of whether
3892    * _VMS_WAIT is defined.
3893    */
3894   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3895 #endif
3896 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3897    created with popen(); otherwise partially emulate waitpid() unless
3898    we have a suitable one from the CRTL that came with VMS 7.2 and later.
3899    Also check processes not considered by the CRTL waitpid().
3900  */
3901 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3902 Pid_t
3903 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3904 {
3905     pInfo info;
3906     int done;
3907     int sts;
3908     int j;
3909
3910     if (statusp) *statusp = 0;
3911
3912     for (info = open_pipes; info != NULL; info = info->next)
3913         if (info->pid == pid) break;
3914
3915     if (info != NULL) {  /* we know about this child */
3916       while (!info->done) {
3917           _ckvmssts(sys$setast(0));
3918           done = info->done;
3919           if (!done) _ckvmssts(sys$clref(pipe_ef));
3920           _ckvmssts(sys$setast(1));
3921           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3922       }
3923
3924       if (statusp) *statusp = info->completion;
3925       return pid;
3926     }
3927
3928     /* child that already terminated? */
3929
3930     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3931         if (closed_list[j].pid == pid) {
3932             if (statusp) *statusp = closed_list[j].completion;
3933             return pid;
3934         }
3935     }
3936
3937     /* fall through if this child is not one of our own pipe children */
3938
3939 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3940
3941       /* waitpid() became available in the CRTL as of VMS 7.0, but only
3942        * in 7.2 did we get a version that fills in the VMS completion
3943        * status as Perl has always tried to do.
3944        */
3945
3946       sts = __vms_waitpid( pid, statusp, flags );
3947
3948       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3949          return sts;
3950
3951       /* If the real waitpid tells us the child does not exist, we
3952        * fall through here to implement waiting for a child that
3953        * was created by some means other than exec() (say, spawned
3954        * from DCL) or to wait for a process that is not a subprocess
3955        * of the current process.
3956        */
3957
3958 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3959
3960     {
3961       $DESCRIPTOR(intdsc,"0 00:00:01");
3962       unsigned long int ownercode = JPI$_OWNER, ownerpid;
3963       unsigned long int pidcode = JPI$_PID, mypid;
3964       unsigned long int interval[2];
3965       unsigned int jpi_iosb[2];
3966       struct itmlst_3 jpilist[2] = {
3967           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
3968           {                      0,         0,                 0, 0}
3969       };
3970
3971       if (pid <= 0) {
3972         /* Sorry folks, we don't presently implement rooting around for
3973            the first child we can find, and we definitely don't want to
3974            pass a pid of -1 to $getjpi, where it is a wildcard operation.
3975          */
3976         set_errno(ENOTSUP);
3977         return -1;
3978       }
3979
3980       /* Get the owner of the child so I can warn if it's not mine. If the
3981        * process doesn't exist or I don't have the privs to look at it,
3982        * I can go home early.
3983        */
3984       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3985       if (sts & 1) sts = jpi_iosb[0];
3986       if (!(sts & 1)) {
3987         switch (sts) {
3988             case SS$_NONEXPR:
3989                 set_errno(ECHILD);
3990                 break;
3991             case SS$_NOPRIV:
3992                 set_errno(EACCES);
3993                 break;
3994             default:
3995                 _ckvmssts(sts);
3996         }
3997         set_vaxc_errno(sts);
3998         return -1;
3999       }
4000
4001       if (ckWARN(WARN_EXEC)) {
4002         /* remind folks they are asking for non-standard waitpid behavior */
4003         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4004         if (ownerpid != mypid)
4005           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4006                       "waitpid: process %x is not a child of process %x",
4007                       pid,mypid);
4008       }
4009
4010       /* simply check on it once a second until it's not there anymore. */
4011
4012       _ckvmssts(sys$bintim(&intdsc,interval));
4013       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4014             _ckvmssts(sys$schdwk(0,0,interval,0));
4015             _ckvmssts(sys$hiber());
4016       }
4017       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4018
4019       _ckvmssts(sts);
4020       return pid;
4021     }
4022 }  /* end of waitpid() */
4023 /*}}}*/
4024 /*}}}*/
4025 /*}}}*/
4026
4027 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4028 char *
4029 my_gconvert(double val, int ndig, int trail, char *buf)
4030 {
4031   static char __gcvtbuf[DBL_DIG+1];
4032   char *loc;
4033
4034   loc = buf ? buf : __gcvtbuf;
4035
4036 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4037   if (val < 1) {
4038     sprintf(loc,"%.*g",ndig,val);
4039     return loc;
4040   }
4041 #endif
4042
4043   if (val) {
4044     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4045     return gcvt(val,ndig,loc);
4046   }
4047   else {
4048     loc[0] = '0'; loc[1] = '\0';
4049     return loc;
4050   }
4051
4052 }
4053 /*}}}*/
4054
4055 #if 1 /* defined(__VAX) || !defined(NAML$C_MAXRSS) */
4056 static int rms_free_search_context(struct FAB * fab)
4057 {
4058 struct NAM * nam;
4059
4060     nam = fab->fab$l_nam;
4061     nam->nam$b_nop |= NAM$M_SYNCHK;
4062     nam->nam$l_rlf = NULL;
4063     fab->fab$b_dns = 0;
4064     return sys$parse(fab, NULL, NULL);
4065 }
4066
4067 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4068 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4069 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4070 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4071 #define rms_nam_esll(nam) nam.nam$b_esl
4072 #define rms_nam_esl(nam) nam.nam$b_esl
4073 #define rms_nam_name(nam) nam.nam$l_name
4074 #define rms_nam_namel(nam) nam.nam$l_name
4075 #define rms_nam_type(nam) nam.nam$l_type
4076 #define rms_nam_typel(nam) nam.nam$l_type
4077 #define rms_nam_ver(nam) nam.nam$l_ver
4078 #define rms_nam_verl(nam) nam.nam$l_ver
4079 #define rms_nam_rsll(nam) nam.nam$b_rsl
4080 #define rms_nam_rsl(nam) nam.nam$b_rsl
4081 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4082 #define rms_set_fna(fab, nam, name, size) \
4083         fab.fab$b_fns = size; fab.fab$l_fna = name;
4084 #define rms_get_fna(fab, nam) fab.fab$l_fna
4085 #define rms_set_dna(fab, nam, name, size) \
4086         fab.fab$b_dns = size; fab.fab$l_dna = name;
4087 #define rms_nam_dns(fab, nam) fab.fab$b_dns;
4088 #define rms_set_esa(fab, nam, name, size) \
4089         nam.nam$b_ess = size; nam.nam$l_esa = name;
4090 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4091         nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
4092 #define rms_set_rsa(nam, name, size) \
4093         nam.nam$l_rsa = name; nam.nam$b_rss = size;
4094 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4095         nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
4096
4097 #else
4098 static int rms_free_search_context(struct FAB * fab)
4099 {
4100 struct NAML * nam;
4101
4102     nam = fab->fab$l_naml;
4103     nam->naml$b_nop |= NAM$M_SYNCHK;
4104     nam->naml$l_rlf = NULL;
4105     nam->naml$l_long_defname_size = 0;
4106     fab->fab$b_dns = 0;
4107     return sys$parse(fab, NULL, NULL);
4108 }
4109
4110 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4111 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4112 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4113 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4114 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4115 #define rms_nam_esl(nam) nam.naml$b_esl
4116 #define rms_nam_name(nam) nam.naml$l_name
4117 #define rms_nam_namel(nam) nam.naml$l_long_name
4118 #define rms_nam_type(nam) nam.naml$l_type
4119 #define rms_nam_typel(nam) nam.naml$l_long_type
4120 #define rms_nam_ver(nam) nam.naml$l_ver
4121 #define rms_nam_verl(nam) nam.naml$l_long_ver
4122 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4123 #define rms_nam_rsl(nam) nam.naml$b_rsl
4124 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4125 #define rms_set_fna(fab, nam, name, size) \
4126         fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4127         nam.naml$l_long_filename_size = size; \
4128         nam.naml$l_long_filename = name
4129 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4130 #define rms_set_dna(fab, nam, name, size) \
4131         fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4132         nam.naml$l_long_defname_size = size; \
4133         nam.naml$l_long_defname = name
4134 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4135 #define rms_set_esa(fab, nam, name, size) \
4136         nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4137         nam.naml$l_long_expand_alloc = size; \
4138         nam.naml$l_long_expand = name
4139 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4140         nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4141         nam.naml$l_long_expand = l_name; \
4142         nam.naml$l_long_expand_alloc = l_size;
4143 #define rms_set_rsa(nam, name, size) \
4144         nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4145         nam.naml$l_long_result = name; \
4146         nam.naml$l_long_result_alloc = size;
4147 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4148         nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4149         nam.naml$l_long_result = l_name; \
4150         nam.naml$l_long_result_alloc = l_size;
4151
4152 #endif
4153
4154
4155 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4156 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4157  * to expand file specification.  Allows for a single default file
4158  * specification and a simple mask of options.  If outbuf is non-NULL,
4159  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4160  * the resultant file specification is placed.  If outbuf is NULL, the
4161  * resultant file specification is placed into a static buffer.
4162  * The third argument, if non-NULL, is taken to be a default file
4163  * specification string.  The fourth argument is unused at present.
4164  * rmesexpand() returns the address of the resultant string if
4165  * successful, and NULL on error.
4166  *
4167  * New functionality for previously unused opts value:
4168  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4169  */
4170 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
4171
4172 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4173 /* ODS-2 only version */
4174 static char *
4175 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4176 {
4177   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
4178   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
4179   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
4180   struct FAB myfab = cc$rms_fab;
4181   struct NAM mynam = cc$rms_nam;
4182   STRLEN speclen;
4183   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4184   int sts;
4185
4186   if (!filespec || !*filespec) {
4187     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4188     return NULL;
4189   }
4190   if (!outbuf) {
4191     if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
4192     else    outbuf = __rmsexpand_retbuf;
4193   }
4194   isunix = is_unix_filespec(filespec);
4195   if (isunix) {
4196     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4197         if (out)
4198            Safefree(out);
4199         return NULL;
4200     }
4201     filespec = vmsfspec;
4202   }
4203
4204   myfab.fab$l_fna = (char *)filespec;  /* cast ok for read only pointer */
4205   myfab.fab$b_fns = strlen(filespec);
4206   myfab.fab$l_nam = &mynam;
4207
4208   if (defspec && *defspec) {
4209     if (strchr(defspec,'/') != NULL) {
4210       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4211         if (out)
4212            Safefree(out);
4213         return NULL;
4214       }
4215       defspec = tmpfspec;
4216     }
4217     myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
4218     myfab.fab$b_dns = strlen(defspec);
4219   }
4220
4221   mynam.nam$l_esa = esa;
4222   mynam.nam$b_ess = sizeof esa;
4223   mynam.nam$l_rsa = outbuf;
4224   mynam.nam$b_rss = NAM$C_MAXRSS;
4225
4226 #ifdef NAM$M_NO_SHORT_UPCASE
4227   if (decc_efs_case_preserve)
4228     mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4229 #endif
4230
4231   retsts = sys$parse(&myfab,0,0);
4232   if (!(retsts & 1)) {
4233     mynam.nam$b_nop |= NAM$M_SYNCHK;
4234     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4235       retsts = sys$parse(&myfab,0,0);
4236       if (retsts & 1) goto expanded;
4237     }
4238     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
4239     sts = sys$parse(&myfab,0,0);  /* Free search context */
4240     if (out) Safefree(out);
4241     set_vaxc_errno(retsts);
4242     if      (retsts == RMS$_PRV) set_errno(EACCES);
4243     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4244     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4245     else                         set_errno(EVMSERR);
4246     return NULL;
4247   }
4248   retsts = sys$search(&myfab,0,0);
4249   if (!(retsts & 1) && retsts != RMS$_FNF) {
4250     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4251     myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
4252     if (out) Safefree(out);
4253     set_vaxc_errno(retsts);
4254     if      (retsts == RMS$_PRV) set_errno(EACCES);
4255     else                         set_errno(EVMSERR);
4256     return NULL;
4257   }
4258
4259   /* If the input filespec contained any lowercase characters,
4260    * downcase the result for compatibility with Unix-minded code. */
4261   expanded:
4262   if (!decc_efs_case_preserve) {
4263     for (out = myfab.fab$l_fna; *out; out++)
4264       if (islower(*out)) { haslower = 1; break; }
4265   }
4266   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
4267   else                 { out = esa;    speclen = mynam.nam$b_esl; }
4268   /* Trim off null fields added by $PARSE
4269    * If type > 1 char, must have been specified in original or default spec
4270    * (not true for version; $SEARCH may have added version of existing file).
4271    */
4272   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
4273   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
4274              (mynam.nam$l_ver - mynam.nam$l_type == 1);
4275   if (trimver || trimtype) {
4276     if (defspec && *defspec) {
4277       char defesa[NAM$C_MAXRSS];
4278       struct FAB deffab = cc$rms_fab;
4279       struct NAM defnam = cc$rms_nam;
4280
4281       deffab.fab$l_nam = &defnam;
4282       /* cast below ok for read only pointer */
4283       deffab.fab$l_fna = (char *)defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
4284       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
4285       defnam.nam$b_nop = NAM$M_SYNCHK;
4286 #ifdef NAM$M_NO_SHORT_UPCASE
4287       if (decc_efs_case_preserve)
4288         defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4289 #endif
4290       if (sys$parse(&deffab,0,0) & 1) {
4291         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
4292         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4293       }
4294     }
4295     if (trimver) {
4296       if (*mynam.nam$l_ver != '\"')
4297         speclen = mynam.nam$l_ver - out;
4298     }
4299     if (trimtype) {
4300       /* If we didn't already trim version, copy down */
4301       if (speclen > mynam.nam$l_ver - out)
4302         memmove(mynam.nam$l_type, mynam.nam$l_ver,
4303                speclen - (mynam.nam$l_ver - out));
4304       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4305     }
4306   }
4307   /* If we just had a directory spec on input, $PARSE "helpfully"
4308    * adds an empty name and type for us */
4309   if (mynam.nam$l_name == mynam.nam$l_type &&
4310       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
4311       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4312     speclen = mynam.nam$l_name - out;
4313
4314   /* Posix format specifications must have matching quotes */
4315   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4316     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4317       out[speclen] = '\"';
4318       speclen++;
4319     }
4320   }
4321
4322   out[speclen] = '\0';
4323   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4324
4325   /* Have we been working with an expanded, but not resultant, spec? */
4326   /* Also, convert back to Unix syntax if necessary. */
4327   if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4328     isunix = 0;
4329
4330   if (!mynam.nam$b_rsl) {
4331     if (isunix) {
4332       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4333     }
4334     else strcpy(outbuf,esa);
4335   }
4336   else if (isunix) {
4337     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4338     strcpy(outbuf,tmpfspec);
4339   }
4340   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4341   mynam.nam$l_rsa = NULL;
4342   mynam.nam$b_rss = 0;
4343   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);  /* Free search context */
4344   return outbuf;
4345 }
4346 #else
4347 /* ODS-5 supporting routine */
4348 static char *
4349 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4350 {
4351   static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4352   char * vmsfspec, *tmpfspec;
4353   char * esa, *cp, *out = NULL;
4354   char * tbuf;
4355   char * esal;
4356   char * outbufl;
4357   struct FAB myfab = cc$rms_fab;
4358   rms_setup_nam(mynam);
4359   STRLEN speclen;
4360   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4361   int sts;
4362
4363   if (!filespec || !*filespec) {
4364     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4365     return NULL;
4366   }
4367   if (!outbuf) {
4368     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4369     else    outbuf = __rmsexpand_retbuf;
4370   }
4371
4372   vmsfspec = NULL;
4373   tmpfspec = NULL;
4374   outbufl = NULL;
4375   isunix = is_unix_filespec(filespec);
4376   if (isunix) {
4377     vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4378     if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4379     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4380         PerlMem_free(vmsfspec);
4381         if (out)
4382            Safefree(out);
4383         return NULL;
4384     }
4385     filespec = vmsfspec;
4386
4387      /* Unless we are forcing to VMS format, a UNIX input means
4388       * UNIX output, and that requires long names to be used
4389       */
4390     if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4391         opts |= PERL_RMSEXPAND_M_LONG;
4392     else {
4393         isunix = 0;
4394     }
4395   }
4396
4397   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4398   rms_bind_fab_nam(myfab, mynam);
4399
4400   if (defspec && *defspec) {
4401     int t_isunix;
4402     t_isunix = is_unix_filespec(defspec);
4403     if (t_isunix) {
4404       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4405       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4406       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4407         PerlMem_free(tmpfspec);
4408         if (vmsfspec != NULL)
4409             PerlMem_free(vmsfspec);
4410         if (out)
4411            Safefree(out);
4412         return NULL;
4413       }
4414       defspec = tmpfspec;
4415     }
4416     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4417   }
4418
4419   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4420   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4421 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4422   esal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4423   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4424 #endif
4425   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
4426
4427   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4428     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4429   }
4430   else {
4431 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4432     outbufl = PerlMem_malloc(VMS_MAXRSS);
4433     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4434     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4435 #else
4436     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4437 #endif
4438   }
4439
4440 #ifdef NAM$M_NO_SHORT_UPCASE
4441   if (decc_efs_case_preserve)
4442     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4443 #endif
4444
4445   /* First attempt to parse as an existing file */
4446   retsts = sys$parse(&myfab,0,0);
4447   if (!(retsts & STS$K_SUCCESS)) {
4448
4449     /* Could not find the file, try as syntax only if error is not fatal */
4450     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4451     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4452       retsts = sys$parse(&myfab,0,0);
4453       if (retsts & STS$K_SUCCESS) goto expanded;
4454     }
4455
4456      /* Still could not parse the file specification */
4457     /*----------------------------------------------*/
4458     sts = rms_free_search_context(&myfab); /* Free search context */
4459     if (out) Safefree(out);
4460     if (tmpfspec != NULL)
4461         PerlMem_free(tmpfspec);
4462     if (vmsfspec != NULL)
4463         PerlMem_free(vmsfspec);
4464     if (outbufl != NULL)
4465         PerlMem_free(outbufl);
4466     PerlMem_free(esa);
4467     PerlMem_free(esal);
4468     set_vaxc_errno(retsts);
4469     if      (retsts == RMS$_PRV) set_errno(EACCES);
4470     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4471     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4472     else                         set_errno(EVMSERR);
4473     return NULL;
4474   }
4475   retsts = sys$search(&myfab,0,0);
4476   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4477     sts = rms_free_search_context(&myfab); /* Free search context */
4478     if (out) Safefree(out);
4479     if (tmpfspec != NULL)
4480         PerlMem_free(tmpfspec);
4481     if (vmsfspec != NULL)
4482         PerlMem_free(vmsfspec);
4483     if (outbufl != NULL)
4484         PerlMem_free(outbufl);
4485     PerlMem_free(esa);
4486     PerlMem_free(esal);
4487     set_vaxc_errno(retsts);
4488     if      (retsts == RMS$_PRV) set_errno(EACCES);
4489     else                         set_errno(EVMSERR);
4490     return NULL;
4491   }
4492
4493   /* If the input filespec contained any lowercase characters,
4494    * downcase the result for compatibility with Unix-minded code. */
4495   expanded:
4496   if (!decc_efs_case_preserve) {
4497     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4498       if (islower(*tbuf)) { haslower = 1; break; }
4499   }
4500
4501    /* Is a long or a short name expected */
4502   /*------------------------------------*/
4503   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4504     if (rms_nam_rsll(mynam)) {
4505         tbuf = outbuf;
4506         speclen = rms_nam_rsll(mynam);
4507     }
4508     else {
4509         tbuf = esal; /* Not esa */
4510         speclen = rms_nam_esll(mynam);
4511     }
4512   }
4513   else {
4514     if (rms_nam_rsl(mynam)) {
4515         tbuf = outbuf;
4516         speclen = rms_nam_rsl(mynam);
4517     }
4518     else {
4519         tbuf = esa; /* Not esal */
4520         speclen = rms_nam_esl(mynam);
4521     }
4522   }
4523   /* Trim off null fields added by $PARSE
4524    * If type > 1 char, must have been specified in original or default spec
4525    * (not true for version; $SEARCH may have added version of existing file).
4526    */
4527   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4528   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4529     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4530              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4531   }
4532   else {
4533     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4534              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4535   }
4536   if (trimver || trimtype) {
4537     if (defspec && *defspec) {
4538       char *defesal = NULL;
4539       defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4540       if (defesal != NULL) {
4541         struct FAB deffab = cc$rms_fab;
4542         rms_setup_nam(defnam);
4543
4544         rms_bind_fab_nam(deffab, defnam);
4545
4546         /* Cast ok */
4547         rms_set_fna
4548             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4549
4550         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4551
4552         rms_set_nam_nop(defnam, 0);
4553         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4554 #ifdef NAM$M_NO_SHORT_UPCASE
4555         if (decc_efs_case_preserve)
4556           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4557 #endif
4558         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4559           if (trimver) {
4560              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4561           }
4562           if (trimtype) {
4563             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4564           }
4565         }
4566         PerlMem_free(defesal);
4567       }
4568     }
4569     if (trimver) {
4570       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4571         if (*(rms_nam_verl(mynam)) != '\"')
4572           speclen = rms_nam_verl(mynam) - tbuf;
4573       }
4574       else {
4575         if (*(rms_nam_ver(mynam)) != '\"')
4576           speclen = rms_nam_ver(mynam) - tbuf;
4577       }
4578     }
4579     if (trimtype) {
4580       /* If we didn't already trim version, copy down */
4581       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4582         if (speclen > rms_nam_verl(mynam) - tbuf)
4583           memmove
4584            (rms_nam_typel(mynam),
4585             rms_nam_verl(mynam),
4586             speclen - (rms_nam_verl(mynam) - tbuf));
4587           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4588       }
4589       else {
4590         if (speclen > rms_nam_ver(mynam) - tbuf)
4591           memmove
4592            (rms_nam_type(mynam),
4593             rms_nam_ver(mynam),
4594             speclen - (rms_nam_ver(mynam) - tbuf));
4595           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4596       }
4597     }
4598   }
4599
4600    /* Done with these copies of the input files */
4601   /*-------------------------------------------*/
4602   if (vmsfspec != NULL)
4603         PerlMem_free(vmsfspec);
4604   if (tmpfspec != NULL)
4605         PerlMem_free(tmpfspec);
4606
4607   /* If we just had a directory spec on input, $PARSE "helpfully"
4608    * adds an empty name and type for us */
4609   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4610     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4611         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
4612         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4613       speclen = rms_nam_namel(mynam) - tbuf;
4614   }
4615   else {
4616     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4617         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
4618         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4619       speclen = rms_nam_name(mynam) - tbuf;
4620   }
4621
4622   /* Posix format specifications must have matching quotes */
4623   if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4624     if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4625       tbuf[speclen] = '\"';
4626       speclen++;
4627     }
4628   }
4629   tbuf[speclen] = '\0';
4630   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4631
4632   /* Have we been working with an expanded, but not resultant, spec? */
4633   /* Also, convert back to Unix syntax if necessary. */
4634
4635   if (!rms_nam_rsll(mynam)) {
4636     if (isunix) {
4637       if (do_tounixspec(esa,outbuf,0) == NULL) {
4638         if (out) Safefree(out);
4639         PerlMem_free(esal);
4640         PerlMem_free(esa);
4641         if (outbufl != NULL)
4642             PerlMem_free(outbufl);
4643         return NULL;
4644       }
4645     }
4646     else strcpy(outbuf,esa);
4647   }
4648   else if (isunix) {
4649     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4650     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4651     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4652         if (out) Safefree(out);
4653         PerlMem_free(esa);
4654         PerlMem_free(esal);
4655         PerlMem_free(tmpfspec);
4656         if (outbufl != NULL)
4657             PerlMem_free(outbufl);
4658         return NULL;
4659     }
4660     strcpy(outbuf,tmpfspec);
4661     PerlMem_free(tmpfspec);
4662   }
4663
4664   rms_set_rsal(mynam, NULL, 0, NULL, 0);
4665   sts = rms_free_search_context(&myfab); /* Free search context */
4666   PerlMem_free(esa);
4667   PerlMem_free(esal);
4668   if (outbufl != NULL)
4669      PerlMem_free(outbufl);
4670   return outbuf;
4671 }
4672 #endif
4673 /*}}}*/
4674 /* External entry points */
4675 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4676 { return do_rmsexpand(spec,buf,0,def,opt); }
4677 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4678 { return do_rmsexpand(spec,buf,1,def,opt); }
4679
4680
4681 /*
4682 ** The following routines are provided to make life easier when
4683 ** converting among VMS-style and Unix-style directory specifications.
4684 ** All will take input specifications in either VMS or Unix syntax. On
4685 ** failure, all return NULL.  If successful, the routines listed below
4686 ** return a pointer to a buffer containing the appropriately
4687 ** reformatted spec (and, therefore, subsequent calls to that routine
4688 ** will clobber the result), while the routines of the same names with
4689 ** a _ts suffix appended will return a pointer to a mallocd string
4690 ** containing the appropriately reformatted spec.
4691 ** In all cases, only explicit syntax is altered; no check is made that
4692 ** the resulting string is valid or that the directory in question
4693 ** actually exists.
4694 **
4695 **   fileify_dirspec() - convert a directory spec into the name of the
4696 **     directory file (i.e. what you can stat() to see if it's a dir).
4697 **     The style (VMS or Unix) of the result is the same as the style
4698 **     of the parameter passed in.
4699 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4700 **     what you prepend to a filename to indicate what directory it's in).
4701 **     The style (VMS or Unix) of the result is the same as the style
4702 **     of the parameter passed in.
4703 **   tounixpath() - convert a directory spec into a Unix-style path.
4704 **   tovmspath() - convert a directory spec into a VMS-style path.
4705 **   tounixspec() - convert any file spec into a Unix-style file spec.
4706 **   tovmsspec() - convert any file spec into a VMS-style spec.
4707 **
4708 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4709 ** Permission is given to distribute this code as part of the Perl
4710 ** standard distribution under the terms of the GNU General Public
4711 ** License or the Perl Artistic License.  Copies of each may be
4712 ** found in the Perl standard distribution.
4713  */
4714
4715 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4716 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4717 {
4718     static char __fileify_retbuf[VMS_MAXRSS];
4719     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4720     char *retspec, *cp1, *cp2, *lastdir;
4721     char *trndir, *vmsdir;
4722     unsigned short int trnlnm_iter_count;
4723     int sts;
4724
4725     if (!dir || !*dir) {
4726       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4727     }
4728     dirlen = strlen(dir);
4729     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4730     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4731       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4732         dir = "/sys$disk";
4733         dirlen = 9;
4734       }
4735       else
4736         dirlen = 1;
4737     }
4738     if (dirlen > (VMS_MAXRSS - 1)) {
4739       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4740       return NULL;
4741     }
4742     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4743     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4744     if (!strpbrk(dir+1,"/]>:")  &&
4745         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4746       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4747       trnlnm_iter_count = 0;
4748       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4749         trnlnm_iter_count++;
4750         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4751       }
4752       dirlen = strlen(trndir);
4753     }
4754     else {
4755       strncpy(trndir,dir,dirlen);
4756       trndir[dirlen] = '\0';
4757     }
4758
4759     /* At this point we are done with *dir and use *trndir which is a
4760      * copy that can be modified.  *dir must not be modified.
4761      */
4762
4763     /* If we were handed a rooted logical name or spec, treat it like a
4764      * simple directory, so that
4765      *    $ Define myroot dev:[dir.]
4766      *    ... do_fileify_dirspec("myroot",buf,1) ...
4767      * does something useful.
4768      */
4769     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4770       trndir[--dirlen] = '\0';
4771       trndir[dirlen-1] = ']';
4772     }
4773     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4774       trndir[--dirlen] = '\0';
4775       trndir[dirlen-1] = '>';
4776     }
4777
4778     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4779       /* If we've got an explicit filename, we can just shuffle the string. */
4780       if (*(cp1+1)) hasfilename = 1;
4781       /* Similarly, we can just back up a level if we've got multiple levels
4782          of explicit directories in a VMS spec which ends with directories. */
4783       else {
4784         for (cp2 = cp1; cp2 > trndir; cp2--) {
4785           if (*cp2 == '.') {
4786             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4787 /* fix-me, can not scan EFS file specs backward like this */
4788               *cp2 = *cp1; *cp1 = '\0';
4789               hasfilename = 1;
4790               break;
4791             }
4792           }
4793           if (*cp2 == '[' || *cp2 == '<') break;
4794         }
4795       }
4796     }
4797
4798     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4799     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4800     cp1 = strpbrk(trndir,"]:>");
4801     if (hasfilename || !cp1) { /* Unix-style path or filename */
4802       if (trndir[0] == '.') {
4803         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4804           PerlMem_free(trndir);
4805           PerlMem_free(vmsdir);
4806           return do_fileify_dirspec("[]",buf,ts);
4807         }
4808         else if (trndir[1] == '.' &&
4809                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4810           PerlMem_free(trndir);
4811           PerlMem_free(vmsdir);
4812           return do_fileify_dirspec("[-]",buf,ts);
4813         }
4814       }
4815       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4816         dirlen -= 1;                 /* to last element */
4817         lastdir = strrchr(trndir,'/');
4818       }
4819       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4820         /* If we have "/." or "/..", VMSify it and let the VMS code
4821          * below expand it, rather than repeating the code to handle
4822          * relative components of a filespec here */
4823         do {
4824           if (*(cp1+2) == '.') cp1++;
4825           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4826             char * ret_chr;
4827             if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4828                 PerlMem_free(trndir);
4829                 PerlMem_free(vmsdir);
4830                 return NULL;
4831             }
4832             if (strchr(vmsdir,'/') != NULL) {
4833               /* If do_tovmsspec() returned it, it must have VMS syntax
4834                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
4835                * the time to check this here only so we avoid a recursion
4836                * loop; otherwise, gigo.
4837                */
4838               PerlMem_free(trndir);
4839               PerlMem_free(vmsdir);
4840               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
4841               return NULL;
4842             }
4843             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4844                 PerlMem_free(trndir);
4845                 PerlMem_free(vmsdir);
4846                 return NULL;
4847             }
4848             ret_chr = do_tounixspec(trndir,buf,ts);
4849             PerlMem_free(trndir);
4850             PerlMem_free(vmsdir);
4851             return ret_chr;
4852           }
4853           cp1++;
4854         } while ((cp1 = strstr(cp1,"/.")) != NULL);
4855         lastdir = strrchr(trndir,'/');
4856       }
4857       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4858         char * ret_chr;
4859         /* Ditto for specs that end in an MFD -- let the VMS code
4860          * figure out whether it's a real device or a rooted logical. */
4861
4862         /* This should not happen any more.  Allowing the fake /000000
4863          * in a UNIX pathname causes all sorts of problems when trying
4864          * to run in UNIX emulation.  So the VMS to UNIX conversions
4865          * now remove the fake /000000 directories.
4866          */
4867
4868         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4869         if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4870             PerlMem_free(trndir);
4871             PerlMem_free(vmsdir);
4872             return NULL;
4873         }
4874         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4875             PerlMem_free(trndir);
4876             PerlMem_free(vmsdir);
4877             return NULL;
4878         }
4879         ret_chr = do_tounixspec(trndir,buf,ts);
4880         PerlMem_free(trndir);
4881         PerlMem_free(vmsdir);
4882         return ret_chr;
4883       }
4884       else {
4885
4886         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4887              !(lastdir = cp1 = strrchr(trndir,']')) &&
4888              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4889         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
4890           int ver; char *cp3;
4891
4892           /* For EFS or ODS-5 look for the last dot */
4893           if (decc_efs_charset) {
4894               cp2 = strrchr(cp1,'.');
4895           }
4896           if (vms_process_case_tolerant) {
4897               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4898                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4899                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4900                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4901                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4902                             (ver || *cp3)))))) {
4903                   PerlMem_free(trndir);
4904                   PerlMem_free(vmsdir);
4905                   set_errno(ENOTDIR);
4906                   set_vaxc_errno(RMS$_DIR);
4907                   return NULL;
4908               }
4909           }
4910           else {
4911               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4912                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4913                   !*(cp2+3) || *(cp2+3) != 'R' ||
4914                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4915                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4916                             (ver || *cp3)))))) {
4917                  PerlMem_free(trndir);
4918                  PerlMem_free(vmsdir);
4919                  set_errno(ENOTDIR);
4920                  set_vaxc_errno(RMS$_DIR);
4921                  return NULL;
4922               }
4923           }
4924           dirlen = cp2 - trndir;
4925         }
4926       }
4927
4928       retlen = dirlen + 6;
4929       if (buf) retspec = buf;
4930       else if (ts) Newx(retspec,retlen+1,char);
4931       else retspec = __fileify_retbuf;
4932       memcpy(retspec,trndir,dirlen);
4933       retspec[dirlen] = '\0';
4934
4935       /* We've picked up everything up to the directory file name.
4936          Now just add the type and version, and we're set. */
4937       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4938         strcat(retspec,".dir;1");
4939       else
4940         strcat(retspec,".DIR;1");
4941       PerlMem_free(trndir);
4942       PerlMem_free(vmsdir);
4943       return retspec;
4944     }
4945     else {  /* VMS-style directory spec */
4946
4947       char *esa, term, *cp;
4948       unsigned long int sts, cmplen, haslower = 0;
4949       unsigned int nam_fnb;
4950       char * nam_type;
4951       struct FAB dirfab = cc$rms_fab;
4952       rms_setup_nam(savnam);
4953       rms_setup_nam(dirnam);
4954
4955       esa = PerlMem_malloc(VMS_MAXRSS + 1);
4956       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4957       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4958       rms_bind_fab_nam(dirfab, dirnam);
4959       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4960       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4961 #ifdef NAM$M_NO_SHORT_UPCASE
4962       if (decc_efs_case_preserve)
4963         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4964 #endif
4965
4966       for (cp = trndir; *cp; cp++)
4967         if (islower(*cp)) { haslower = 1; break; }
4968       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4969         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4970           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4971           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4972         }
4973         if (!sts) {
4974           PerlMem_free(esa);
4975           PerlMem_free(trndir);
4976           PerlMem_free(vmsdir);
4977           set_errno(EVMSERR);
4978           set_vaxc_errno(dirfab.fab$l_sts);
4979           return NULL;
4980         }
4981       }
4982       else {
4983         savnam = dirnam;
4984         /* Does the file really exist? */
4985         if (sys$search(&dirfab)& STS$K_SUCCESS) {
4986           /* Yes; fake the fnb bits so we'll check type below */
4987         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4988         }
4989         else { /* No; just work with potential name */
4990           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4991           else {
4992             PerlMem_free(esa);
4993             PerlMem_free(trndir);
4994             PerlMem_free(vmsdir);
4995             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
4996             sts = rms_free_search_context(&dirfab);
4997             return NULL;
4998           }
4999         }
5000       }
5001       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5002         cp1 = strchr(esa,']');
5003         if (!cp1) cp1 = strchr(esa,'>');
5004         if (cp1) {  /* Should always be true */
5005           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5006           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5007         }
5008       }
5009       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5010         /* Yep; check version while we're at it, if it's there. */
5011         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5012         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5013           /* Something other than .DIR[;1].  Bzzt. */
5014           sts = rms_free_search_context(&dirfab);
5015           PerlMem_free(esa);
5016           PerlMem_free(trndir);
5017           PerlMem_free(vmsdir);
5018           set_errno(ENOTDIR);
5019           set_vaxc_errno(RMS$_DIR);
5020           return NULL;
5021         }
5022       }
5023       esa[rms_nam_esll(dirnam)] = '\0';
5024       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5025         /* They provided at least the name; we added the type, if necessary, */
5026         if (buf) retspec = buf;                            /* in sys$parse() */
5027         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5028         else retspec = __fileify_retbuf;
5029         strcpy(retspec,esa);
5030         sts = rms_free_search_context(&dirfab);
5031         PerlMem_free(trndir);
5032         PerlMem_free(esa);
5033         PerlMem_free(vmsdir);
5034         return retspec;
5035       }
5036       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5037         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5038         *cp1 = '\0';
5039         rms_nam_esll(dirnam) -= 9;
5040       }
5041       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5042       if (cp1 == NULL) { /* should never happen */
5043         sts = rms_free_search_context(&dirfab);
5044         PerlMem_free(trndir);
5045         PerlMem_free(esa);
5046         PerlMem_free(vmsdir);
5047         return NULL;
5048       }
5049       term = *cp1;
5050       *cp1 = '\0';
5051       retlen = strlen(esa);
5052       cp1 = strrchr(esa,'.');
5053       /* ODS-5 directory specifications can have extra "." in them. */
5054       /* Fix-me, can not scan EFS file specifications backwards */
5055       while (cp1 != NULL) {
5056         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5057           break;
5058         else {
5059            cp1--;
5060            while ((cp1 > esa) && (*cp1 != '.'))
5061              cp1--;
5062         }
5063         if (cp1 == esa)
5064           cp1 = NULL;
5065       }
5066
5067       if ((cp1) != NULL) {
5068         /* There's more than one directory in the path.  Just roll back. */
5069         *cp1 = term;
5070         if (buf) retspec = buf;
5071         else if (ts) Newx(retspec,retlen+7,char);
5072         else retspec = __fileify_retbuf;
5073         strcpy(retspec,esa);
5074       }
5075       else {
5076         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5077           /* Go back and expand rooted logical name */
5078           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5079 #ifdef NAM$M_NO_SHORT_UPCASE
5080           if (decc_efs_case_preserve)
5081             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5082 #endif
5083           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5084             sts = rms_free_search_context(&dirfab);
5085             PerlMem_free(esa);
5086             PerlMem_free(trndir);
5087             PerlMem_free(vmsdir);
5088             set_errno(EVMSERR);
5089             set_vaxc_errno(dirfab.fab$l_sts);
5090             return NULL;
5091           }
5092           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5093           if (buf) retspec = buf;
5094           else if (ts) Newx(retspec,retlen+16,char);
5095           else retspec = __fileify_retbuf;
5096           cp1 = strstr(esa,"][");
5097           if (!cp1) cp1 = strstr(esa,"]<");
5098           dirlen = cp1 - esa;
5099           memcpy(retspec,esa,dirlen);
5100           if (!strncmp(cp1+2,"000000]",7)) {
5101             retspec[dirlen-1] = '\0';
5102             /* fix-me Not full ODS-5, just extra dots in directories for now */
5103             cp1 = retspec + dirlen - 1;
5104             while (cp1 > retspec)
5105             {
5106               if (*cp1 == '[')
5107                 break;
5108               if (*cp1 == '.') {
5109                 if (*(cp1-1) != '^')
5110                   break;
5111               }
5112               cp1--;
5113             }
5114             if (*cp1 == '.') *cp1 = ']';
5115             else {
5116               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5117               memmove(cp1+1,"000000]",7);
5118             }
5119           }
5120           else {
5121             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5122             retspec[retlen] = '\0';
5123             /* Convert last '.' to ']' */
5124             cp1 = retspec+retlen-1;
5125             while (*cp != '[') {
5126               cp1--;
5127               if (*cp1 == '.') {
5128                 /* Do not trip on extra dots in ODS-5 directories */
5129                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5130                 break;
5131               }
5132             }
5133             if (*cp1 == '.') *cp1 = ']';
5134             else {
5135               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5136               memmove(cp1+1,"000000]",7);
5137             }
5138           }
5139         }
5140         else {  /* This is a top-level dir.  Add the MFD to the path. */
5141           if (buf) retspec = buf;
5142           else if (ts) Newx(retspec,retlen+16,char);
5143           else retspec = __fileify_retbuf;
5144           cp1 = esa;
5145           cp2 = retspec;
5146           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5147           strcpy(cp2,":[000000]");
5148           cp1 += 2;
5149           strcpy(cp2+9,cp1);
5150         }
5151       }
5152       sts = rms_free_search_context(&dirfab);
5153       /* We've set up the string up through the filename.  Add the
5154          type and version, and we're done. */
5155       strcat(retspec,".DIR;1");
5156
5157       /* $PARSE may have upcased filespec, so convert output to lower
5158        * case if input contained any lowercase characters. */
5159       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5160       PerlMem_free(trndir);
5161       PerlMem_free(esa);
5162       PerlMem_free(vmsdir);
5163       return retspec;
5164     }
5165 }  /* end of do_fileify_dirspec() */
5166 /*}}}*/
5167 /* External entry points */
5168 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5169 { return do_fileify_dirspec(dir,buf,0); }
5170 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5171 { return do_fileify_dirspec(dir,buf,1); }
5172
5173 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5174 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
5175 {
5176     static char __pathify_retbuf[VMS_MAXRSS];
5177     unsigned long int retlen;
5178     char *retpath, *cp1, *cp2, *trndir;
5179     unsigned short int trnlnm_iter_count;
5180     STRLEN trnlen;
5181     int sts;
5182
5183     if (!dir || !*dir) {
5184       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5185     }
5186
5187     trndir = PerlMem_malloc(VMS_MAXRSS);
5188     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5189     if (*dir) strcpy(trndir,dir);
5190     else getcwd(trndir,VMS_MAXRSS - 1);
5191
5192     trnlnm_iter_count = 0;
5193     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5194            && my_trnlnm(trndir,trndir,0)) {
5195       trnlnm_iter_count++;
5196       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5197       trnlen = strlen(trndir);
5198
5199       /* Trap simple rooted lnms, and return lnm:[000000] */
5200       if (!strcmp(trndir+trnlen-2,".]")) {
5201         if (buf) retpath = buf;
5202         else if (ts) Newx(retpath,strlen(dir)+10,char);
5203         else retpath = __pathify_retbuf;
5204         strcpy(retpath,dir);
5205         strcat(retpath,":[000000]");
5206         PerlMem_free(trndir);
5207         return retpath;
5208       }
5209     }
5210
5211     /* At this point we do not work with *dir, but the copy in
5212      * *trndir that is modifiable.
5213      */
5214
5215     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5216       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5217                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5218         retlen = 2 + (*(trndir+1) != '\0');
5219       else {
5220         if ( !(cp1 = strrchr(trndir,'/')) &&
5221              !(cp1 = strrchr(trndir,']')) &&
5222              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5223         if ((cp2 = strchr(cp1,'.')) != NULL &&
5224             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5225              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5226               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5227               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5228           int ver; char *cp3;
5229
5230           /* For EFS or ODS-5 look for the last dot */
5231           if (decc_efs_charset) {
5232             cp2 = strrchr(cp1,'.');
5233           }
5234           if (vms_process_case_tolerant) {
5235               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5236                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5237                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5238                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5239                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5240                             (ver || *cp3)))))) {
5241                 PerlMem_free(trndir);
5242                 set_errno(ENOTDIR);
5243                 set_vaxc_errno(RMS$_DIR);
5244                 return NULL;
5245               }
5246           }
5247           else {
5248               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5249                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5250                   !*(cp2+3) || *(cp2+3) != 'R' ||
5251                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5252                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5253                             (ver || *cp3)))))) {
5254                 PerlMem_free(trndir);
5255                 set_errno(ENOTDIR);
5256                 set_vaxc_errno(RMS$_DIR);
5257                 return NULL;
5258               }
5259           }
5260           retlen = cp2 - trndir + 1;
5261         }
5262         else {  /* No file type present.  Treat the filename as a directory. */
5263           retlen = strlen(trndir) + 1;
5264         }
5265       }
5266       if (buf) retpath = buf;
5267       else if (ts) Newx(retpath,retlen+1,char);
5268       else retpath = __pathify_retbuf;
5269       strncpy(retpath, trndir, retlen-1);
5270       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5271         retpath[retlen-1] = '/';      /* with '/', add it. */
5272         retpath[retlen] = '\0';
5273       }
5274       else retpath[retlen-1] = '\0';
5275     }
5276     else {  /* VMS-style directory spec */
5277       char *esa, *cp;
5278       unsigned long int sts, cmplen, haslower;
5279       struct FAB dirfab = cc$rms_fab;
5280       int dirlen;
5281       rms_setup_nam(savnam);
5282       rms_setup_nam(dirnam);
5283
5284       /* If we've got an explicit filename, we can just shuffle the string. */
5285       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5286              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5287         if ((cp2 = strchr(cp1,'.')) != NULL) {
5288           int ver; char *cp3;
5289           if (vms_process_case_tolerant) {
5290               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5291                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5292                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5293                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5294                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5295                             (ver || *cp3)))))) {
5296                PerlMem_free(trndir);
5297                set_errno(ENOTDIR);
5298                set_vaxc_errno(RMS$_DIR);
5299                return NULL;
5300              }
5301           }
5302           else {
5303               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5304                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5305                   !*(cp2+3) || *(cp2+3) != 'R' ||
5306                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5307                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5308                             (ver || *cp3)))))) {
5309                PerlMem_free(trndir);
5310                set_errno(ENOTDIR);
5311                set_vaxc_errno(RMS$_DIR);
5312                return NULL;
5313              }
5314           }
5315         }
5316         else {  /* No file type, so just draw name into directory part */
5317           for (cp2 = cp1; *cp2; cp2++) ;
5318         }
5319         *cp2 = *cp1;
5320         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5321         *cp1 = '.';
5322         /* We've now got a VMS 'path'; fall through */
5323       }
5324
5325       dirlen = strlen(trndir);
5326       if (trndir[dirlen-1] == ']' ||
5327           trndir[dirlen-1] == '>' ||
5328           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5329         if (buf) retpath = buf;
5330         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5331         else retpath = __pathify_retbuf;
5332         strcpy(retpath,trndir);
5333         PerlMem_free(trndir);
5334         return retpath;
5335       }
5336       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5337       esa = PerlMem_malloc(VMS_MAXRSS);
5338       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5339       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5340       rms_bind_fab_nam(dirfab, dirnam);
5341       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5342 #ifdef NAM$M_NO_SHORT_UPCASE
5343       if (decc_efs_case_preserve)
5344           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5345 #endif
5346
5347       for (cp = trndir; *cp; cp++)
5348         if (islower(*cp)) { haslower = 1; break; }
5349
5350       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5351         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5352           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5353           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5354         }
5355         if (!sts) {
5356           PerlMem_free(trndir);
5357           PerlMem_free(esa);
5358           set_errno(EVMSERR);
5359           set_vaxc_errno(dirfab.fab$l_sts);
5360           return NULL;
5361         }
5362       }
5363       else {
5364         savnam = dirnam;
5365         /* Does the file really exist? */
5366         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5367           if (dirfab.fab$l_sts != RMS$_FNF) {
5368             int sts1;
5369             sts1 = rms_free_search_context(&dirfab);
5370             PerlMem_free(trndir);
5371             PerlMem_free(esa);
5372             set_errno(EVMSERR);
5373             set_vaxc_errno(dirfab.fab$l_sts);
5374             return NULL;
5375           }
5376           dirnam = savnam; /* No; just work with potential name */
5377         }
5378       }
5379       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5380         /* Yep; check version while we're at it, if it's there. */
5381         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5382         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5383           int sts2;
5384           /* Something other than .DIR[;1].  Bzzt. */
5385           sts2 = rms_free_search_context(&dirfab);
5386           PerlMem_free(trndir);
5387           PerlMem_free(esa);
5388           set_errno(ENOTDIR);
5389           set_vaxc_errno(RMS$_DIR);
5390           return NULL;
5391         }
5392       }
5393       /* OK, the type was fine.  Now pull any file name into the
5394          directory path. */
5395       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5396       else {
5397         cp1 = strrchr(esa,'>');
5398         *(rms_nam_typel(dirnam)) = '>';
5399       }
5400       *cp1 = '.';
5401       *(rms_nam_typel(dirnam) + 1) = '\0';
5402       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5403       if (buf) retpath = buf;
5404       else if (ts) Newx(retpath,retlen,char);
5405       else retpath = __pathify_retbuf;
5406       strcpy(retpath,esa);
5407       PerlMem_free(esa);
5408       sts = rms_free_search_context(&dirfab);
5409       /* $PARSE may have upcased filespec, so convert output to lower
5410        * case if input contained any lowercase characters. */
5411       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5412     }
5413
5414     PerlMem_free(trndir);
5415     return retpath;
5416 }  /* end of do_pathify_dirspec() */
5417 /*}}}*/
5418 /* External entry points */
5419 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5420 { return do_pathify_dirspec(dir,buf,0); }
5421 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5422 { return do_pathify_dirspec(dir,buf,1); }
5423
5424 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5425 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5426 {
5427   static char __tounixspec_retbuf[VMS_MAXRSS];
5428   char *dirend, *rslt, *cp1, *cp3, *tmp;
5429   const char *cp2;
5430   int devlen, dirlen, retlen = VMS_MAXRSS;
5431   int expand = 1; /* guarantee room for leading and trailing slashes */
5432   unsigned short int trnlnm_iter_count;
5433   int cmp_rslt;
5434
5435   if (spec == NULL) return NULL;
5436   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
5437   if (buf) rslt = buf;
5438   else if (ts) {
5439     retlen = strlen(spec);
5440     cp1 = strchr(spec,'[');
5441     if (!cp1) cp1 = strchr(spec,'<');
5442     if (cp1) {
5443       for (cp1++; *cp1; cp1++) {
5444         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
5445         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
5446           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
5447       }
5448     }
5449     Newx(rslt,retlen+2+2*expand,char);
5450   }
5451   else rslt = __tounixspec_retbuf;
5452
5453   /* New VMS specific format needs translation
5454    * glob passes filenames with trailing '\n' and expects this preserved.
5455    */
5456   if (decc_posix_compliant_pathnames) {
5457     if (strncmp(spec, "\"^UP^", 5) == 0) {
5458       char * uspec;
5459       char *tunix;
5460       int tunix_len;
5461       int nl_flag;
5462
5463       tunix = PerlMem_malloc(VMS_MAXRSS);
5464       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5465       strcpy(tunix, spec);
5466       tunix_len = strlen(tunix);
5467       nl_flag = 0;
5468       if (tunix[tunix_len - 1] == '\n') {
5469         tunix[tunix_len - 1] = '\"';
5470         tunix[tunix_len] = '\0';
5471         tunix_len--;
5472         nl_flag = 1;
5473       }
5474       uspec = decc$translate_vms(tunix);
5475       PerlMem_free(tunix);
5476       if ((int)uspec > 0) {
5477         strcpy(rslt,uspec);
5478         if (nl_flag) {
5479           strcat(rslt,"\n");
5480         }
5481         else {
5482           /* If we can not translate it, makemaker wants as-is */
5483           strcpy(rslt, spec);
5484         }
5485         return rslt;
5486       }
5487     }
5488   }
5489
5490   cmp_rslt = 0; /* Presume VMS */
5491   cp1 = strchr(spec, '/');
5492   if (cp1 == NULL)
5493     cmp_rslt = 0;
5494
5495     /* Look for EFS ^/ */
5496     if (decc_efs_charset) {
5497       while (cp1 != NULL) {
5498         cp2 = cp1 - 1;
5499         if (*cp2 != '^') {
5500           /* Found illegal VMS, assume UNIX */
5501           cmp_rslt = 1;
5502           break;
5503         }
5504       cp1++;
5505       cp1 = strchr(cp1, '/');
5506     }
5507   }
5508
5509   /* Look for "." and ".." */
5510   if (decc_filename_unix_report) {
5511     if (spec[0] == '.') {
5512       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5513         cmp_rslt = 1;
5514       }
5515       else {
5516         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5517           cmp_rslt = 1;
5518         }
5519       }
5520     }
5521   }
5522   /* This is already UNIX or at least nothing VMS understands */
5523   if (cmp_rslt) {
5524     strcpy(rslt,spec);
5525     return rslt;
5526   }
5527
5528   cp1 = rslt;
5529   cp2 = spec;
5530   dirend = strrchr(spec,']');
5531   if (dirend == NULL) dirend = strrchr(spec,'>');
5532   if (dirend == NULL) dirend = strchr(spec,':');
5533   if (dirend == NULL) {
5534     strcpy(rslt,spec);
5535     return rslt;
5536   }
5537
5538   /* Special case 1 - sys$posix_root = / */
5539 #if __CRTL_VER >= 70000000
5540   if (!decc_disable_posix_root) {
5541     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5542       *cp1 = '/';
5543       cp1++;
5544       cp2 = cp2 + 15;
5545       }
5546   }
5547 #endif
5548
5549   /* Special case 2 - Convert NLA0: to /dev/null */
5550 #if __CRTL_VER < 70000000
5551   cmp_rslt = strncmp(spec,"NLA0:", 5);
5552   if (cmp_rslt != 0)
5553      cmp_rslt = strncmp(spec,"nla0:", 5);
5554 #else
5555   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5556 #endif
5557   if (cmp_rslt == 0) {
5558     strcpy(rslt, "/dev/null");
5559     cp1 = cp1 + 9;
5560     cp2 = cp2 + 5;
5561     if (spec[6] != '\0') {
5562       cp1[9] == '/';
5563       cp1++;
5564       cp2++;
5565     }
5566   }
5567
5568    /* Also handle special case "SYS$SCRATCH:" */
5569 #if __CRTL_VER < 70000000
5570   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5571   if (cmp_rslt != 0)
5572      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5573 #else
5574   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5575 #endif
5576   tmp = PerlMem_malloc(VMS_MAXRSS);
5577   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5578   if (cmp_rslt == 0) {
5579   int islnm;
5580
5581     islnm = my_trnlnm(tmp, "TMP", 0);
5582     if (!islnm) {
5583       strcpy(rslt, "/tmp");
5584       cp1 = cp1 + 4;
5585       cp2 = cp2 + 12;
5586       if (spec[12] != '\0') {
5587         cp1[4] == '/';
5588         cp1++;
5589         cp2++;
5590       }
5591     }
5592   }
5593
5594   if (*cp2 != '[' && *cp2 != '<') {
5595     *(cp1++) = '/';
5596   }
5597   else {  /* the VMS spec begins with directories */
5598     cp2++;
5599     if (*cp2 == ']' || *cp2 == '>') {
5600       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5601       PerlMem_free(tmp);
5602       return rslt;
5603     }
5604     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5605       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5606         if (ts) Safefree(rslt);
5607         PerlMem_free(tmp);
5608         return NULL;
5609       }
5610       trnlnm_iter_count = 0;
5611       do {
5612         cp3 = tmp;
5613         while (*cp3 != ':' && *cp3) cp3++;
5614         *(cp3++) = '\0';
5615         if (strchr(cp3,']') != NULL) break;
5616         trnlnm_iter_count++;
5617         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5618       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5619       if (ts && !buf &&
5620           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5621         retlen = devlen + dirlen;
5622         Renew(rslt,retlen+1+2*expand,char);
5623         cp1 = rslt;
5624       }
5625       cp3 = tmp;
5626       *(cp1++) = '/';
5627       while (*cp3) {
5628         *(cp1++) = *(cp3++);
5629         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5630             PerlMem_free(tmp);
5631             return NULL; /* No room */
5632         }
5633       }
5634       *(cp1++) = '/';
5635     }
5636     if ((*cp2 == '^')) {
5637         /* EFS file escape, pass the next character as is */
5638         /* Fix me: HEX encoding for UNICODE not implemented */
5639         cp2++;
5640     }
5641     else if ( *cp2 == '.') {
5642       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5643         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5644         cp2 += 3;
5645       }
5646       else cp2++;
5647     }
5648   }
5649   PerlMem_free(tmp);
5650   for (; cp2 <= dirend; cp2++) {
5651     if ((*cp2 == '^')) {
5652         /* EFS file escape, pass the next character as is */
5653         /* Fix me: HEX encoding for UNICODE not implemented */
5654         cp2++;
5655         *(cp1++) = *cp2;
5656     }
5657     if (*cp2 == ':') {
5658       *(cp1++) = '/';
5659       if (*(cp2+1) == '[') cp2++;
5660     }
5661     else if (*cp2 == ']' || *cp2 == '>') {
5662       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5663     }
5664     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5665       *(cp1++) = '/';
5666       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5667         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5668                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5669         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5670             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5671       }
5672       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5673         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5674         cp2 += 2;
5675       }
5676     }
5677     else if (*cp2 == '-') {
5678       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5679         while (*cp2 == '-') {
5680           cp2++;
5681           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5682         }
5683         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5684           if (ts) Safefree(rslt);                        /* filespecs like */
5685           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5686           return NULL;
5687         }
5688       }
5689       else *(cp1++) = *cp2;
5690     }
5691     else *(cp1++) = *cp2;
5692   }
5693   while (*cp2) *(cp1++) = *(cp2++);
5694   *cp1 = '\0';
5695
5696   /* This still leaves /000000/ when working with a
5697    * VMS device root or concealed root.
5698    */
5699   {
5700   int ulen;
5701   char * zeros;
5702
5703       ulen = strlen(rslt);
5704
5705       /* Get rid of "000000/ in rooted filespecs */
5706       if (ulen > 7) {
5707         zeros = strstr(rslt, "/000000/");
5708         if (zeros != NULL) {
5709           int mlen;
5710           mlen = ulen - (zeros - rslt) - 7;
5711           memmove(zeros, &zeros[7], mlen);
5712           ulen = ulen - 7;
5713           rslt[ulen] = '\0';
5714         }
5715       }
5716   }
5717
5718   return rslt;
5719
5720 }  /* end of do_tounixspec() */
5721 /*}}}*/
5722 /* External entry points */
5723 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5724 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5725
5726 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5727
5728 static int posix_to_vmsspec
5729   (char *vmspath, int vmspath_len, const char *unixpath) {
5730 int sts;
5731 struct FAB myfab = cc$rms_fab;
5732 struct NAML mynam = cc$rms_naml;
5733 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5734  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5735 char *esa;
5736 char *vms_delim;
5737 int dir_flag;
5738 int unixlen;
5739
5740   /* If not a posix spec already, convert it */
5741   dir_flag = 0;
5742   unixlen = strlen(unixpath);
5743   if (unixlen == 0) {
5744     vmspath[0] = '\0';
5745     return SS$_NORMAL;
5746   }
5747   if (strncmp(unixpath,"\"^UP^",5) != 0) {
5748     sprintf(vmspath,"\"^UP^%s\"",unixpath);
5749   }
5750   else {
5751     /* This is already a VMS specification, no conversion */
5752     unixlen--;
5753     strncpy(vmspath,unixpath, vmspath_len);
5754   }
5755   vmspath[vmspath_len] = 0;
5756   if (unixpath[unixlen - 1] == '/')
5757   dir_flag = 1;
5758   esa = PerlMem_malloc(VMS_MAXRSS);
5759   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5760   myfab.fab$l_fna = vmspath;
5761   myfab.fab$b_fns = strlen(vmspath);
5762   myfab.fab$l_naml = &mynam;
5763   mynam.naml$l_esa = NULL;
5764   mynam.naml$b_ess = 0;
5765   mynam.naml$l_long_expand = esa;
5766   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5767   mynam.naml$l_rsa = NULL;
5768   mynam.naml$b_rss = 0;
5769   if (decc_efs_case_preserve)
5770     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5771   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5772
5773   /* Set up the remaining naml fields */
5774   sts = sys$parse(&myfab);
5775
5776   /* It failed! Try again as a UNIX filespec */
5777   if (!(sts & 1)) {
5778     PerlMem_free(esa);
5779     return sts;
5780   }
5781
5782    /* get the Device ID and the FID */
5783    sts = sys$search(&myfab);
5784    /* on any failure, returned the POSIX ^UP^ filespec */
5785    if (!(sts & 1)) {
5786       PerlMem_free(esa);
5787       return sts;
5788    }
5789    specdsc.dsc$a_pointer = vmspath;
5790    specdsc.dsc$w_length = vmspath_len;
5791
5792    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5793    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5794    sts = lib$fid_to_name
5795       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5796
5797   /* on any failure, returned the POSIX ^UP^ filespec */
5798   if (!(sts & 1)) {
5799      /* This can happen if user does not have permission to read directories */
5800      if (strncmp(unixpath,"\"^UP^",5) != 0)
5801        sprintf(vmspath,"\"^UP^%s\"",unixpath);
5802      else
5803        strcpy(vmspath, unixpath);
5804   }
5805   else {
5806     vmspath[specdsc.dsc$w_length] = 0;
5807
5808     /* Are we expecting a directory? */
5809     if (dir_flag != 0) {
5810     int i;
5811     char *eptr;
5812
5813       eptr = NULL;
5814
5815       i = specdsc.dsc$w_length - 1;
5816       while (i > 0) {
5817       int zercnt;
5818         zercnt = 0;
5819         /* Version must be '1' */
5820         if (vmspath[i--] != '1')
5821           break;
5822         /* Version delimiter is one of ".;" */
5823         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5824           break;
5825         i--;
5826         if (vmspath[i--] != 'R')
5827           break;
5828         if (vmspath[i--] != 'I')
5829           break;
5830         if (vmspath[i--] != 'D')
5831           break;
5832         if (vmspath[i--] != '.')
5833           break;
5834         eptr = &vmspath[i+1];
5835         while (i > 0) {
5836           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5837             if (vmspath[i-1] != '^') {
5838               if (zercnt != 6) {
5839                 *eptr = vmspath[i];
5840                 eptr[1] = '\0';
5841                 vmspath[i] = '.';
5842                 break;
5843               }
5844               else {
5845                 /* Get rid of 6 imaginary zero directory filename */
5846                 vmspath[i+1] = '\0';
5847               }
5848             }
5849           }
5850           if (vmspath[i] == '0')
5851             zercnt++;
5852           else
5853             zercnt = 10;
5854           i--;
5855         }
5856         break;
5857       }
5858     }
5859   }
5860   PerlMem_free(esa);
5861   return sts;
5862 }
5863
5864 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5865 static int posix_to_vmsspec_hardway
5866   (char *vmspath, int vmspath_len, const char *unixpath) {
5867
5868 char *esa;
5869 const char *unixptr;
5870 char *vmsptr;
5871 const char *lastslash;
5872 const char *lastdot;
5873 int unixlen;
5874 int vmslen;
5875 int dir_start;
5876 int dir_dot;
5877 int quoted;
5878
5879
5880   unixptr = unixpath;
5881   dir_dot = 0;
5882
5883   /* Ignore leading "/" characters */
5884   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5885     unixptr++;
5886   }
5887   unixlen = strlen(unixptr);
5888
5889   /* Do nothing with blank paths */
5890   if (unixlen == 0) {
5891     vmspath[0] = '\0';
5892     return SS$_NORMAL;
5893   }
5894
5895   lastslash = strrchr(unixptr,'/');
5896   lastdot = strrchr(unixptr,'.');
5897
5898
5899   /* last dot is last dot or past end of string */
5900   if (lastdot == NULL)
5901     lastdot = unixptr + unixlen;
5902
5903   /* if no directories, set last slash to beginning of string */
5904   if (lastslash == NULL) {
5905     lastslash = unixptr;
5906   }
5907   else {
5908     /* Watch out for trailing "." after last slash, still a directory */
5909     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5910       lastslash = unixptr + unixlen;
5911     }
5912
5913     /* Watch out for traiing ".." after last slash, still a directory */
5914     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5915       lastslash = unixptr + unixlen;
5916     }
5917
5918     /* dots in directories are aways escaped */
5919     if (lastdot < lastslash)
5920       lastdot = unixptr + unixlen;
5921   }
5922
5923   /* if (unixptr < lastslash) then we are in a directory */
5924
5925   dir_start = 0;
5926   quoted = 0;
5927
5928   vmsptr = vmspath;
5929   vmslen = 0;
5930
5931   /* This could have a "^UP^ on the front */
5932   if (strncmp(unixptr,"\"^UP^",5) == 0) {
5933     quoted = 1;
5934     unixptr+= 5;
5935   }
5936
5937   /* Start with the UNIX path */
5938   if (*unixptr != '/') {
5939     /* relative paths */
5940     if (lastslash > unixptr) {
5941     int dotdir_seen;
5942
5943       /* skip leading ./ */
5944       dotdir_seen = 0;
5945       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5946         dotdir_seen = 1;
5947         unixptr++;
5948         unixptr++;
5949       }
5950
5951       /* Are we still in a directory? */
5952       if (unixptr <= lastslash) {
5953         *vmsptr++ = '[';
5954         vmslen = 1;
5955         dir_start = 1;
5956
5957         /* if not backing up, then it is relative forward. */
5958         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5959               ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5960           *vmsptr++ = '.';
5961           vmslen++;
5962           dir_dot = 1;
5963         }
5964        }
5965        else {
5966          if (dotdir_seen) {
5967            /* Perl wants an empty directory here to tell the difference
5968             * between a DCL commmand and a filename
5969             */
5970           *vmsptr++ = '[';
5971           *vmsptr++ = ']';
5972           vmslen = 2;
5973         }
5974       }
5975     }
5976     else {
5977       /* Handle two special files . and .. */
5978       if (unixptr[0] == '.') {
5979         if (unixptr[1] == '\0') {
5980           *vmsptr++ = '[';
5981           *vmsptr++ = ']';
5982           vmslen += 2;
5983           *vmsptr++ = '\0';
5984           return SS$_NORMAL;
5985         }
5986         if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5987           *vmsptr++ = '[';
5988           *vmsptr++ = '-';
5989           *vmsptr++ = ']';
5990           vmslen += 3;
5991           *vmsptr++ = '\0';
5992           return SS$_NORMAL;
5993         }
5994       }
5995     }
5996   }
5997   else {        /* Absolute PATH handling */
5998   int sts;
5999   char * nextslash;
6000   int seg_len;
6001     /* Need to find out where root is */
6002
6003     /* In theory, this procedure should never get an absolute POSIX pathname
6004      * that can not be found on the POSIX root.
6005      * In practice, that can not be relied on, and things will show up
6006      * here that are a VMS device name or concealed logical name instead.
6007      * So to make things work, this procedure must be tolerant.
6008      */
6009     esa = PerlMem_malloc(vmspath_len);
6010     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6011
6012     sts = SS$_NORMAL;
6013     nextslash = strchr(&unixptr[1],'/');
6014     seg_len = 0;
6015     if (nextslash != NULL) {
6016       seg_len = nextslash - &unixptr[1];
6017       strncpy(vmspath, unixptr, seg_len + 1);
6018       vmspath[seg_len+1] = 0;
6019       sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
6020     }
6021
6022     if (sts & 1) {
6023       /* This is verified to be a real path */
6024
6025       sts = posix_to_vmsspec(esa, vmspath_len, "/");
6026       strcpy(vmspath, esa);
6027       vmslen = strlen(vmspath);
6028       vmsptr = vmspath + vmslen;
6029       unixptr++;
6030       if (unixptr < lastslash) {
6031       char * rptr;
6032         vmsptr--;
6033         *vmsptr++ = '.';
6034         dir_start = 1;
6035         dir_dot = 1;
6036         if (vmslen > 7) {
6037         int cmp;
6038           rptr = vmsptr - 7;
6039           cmp = strcmp(rptr,"000000.");
6040           if (cmp == 0) {
6041             vmslen -= 7;
6042             vmsptr -= 7;
6043             vmsptr[1] = '\0';
6044           } /* removing 6 zeros */
6045         } /* vmslen < 7, no 6 zeros possible */
6046       } /* Not in a directory */
6047     } /* end of verified real path handling */
6048     else {
6049     int add_6zero;
6050     int islnm;
6051
6052       /* Ok, we have a device or a concealed root that is not in POSIX
6053        * or we have garbage.  Make the best of it.
6054        */
6055
6056       /* Posix to VMS destroyed this, so copy it again */
6057       strncpy(vmspath, &unixptr[1], seg_len);
6058       vmspath[seg_len] = 0;
6059       vmslen = seg_len;
6060       vmsptr = &vmsptr[vmslen];
6061       islnm = 0;
6062
6063       /* Now do we need to add the fake 6 zero directory to it? */
6064       add_6zero = 1;
6065       if ((*lastslash == '/') && (nextslash < lastslash)) {
6066         /* No there is another directory */
6067         add_6zero = 0;
6068       }
6069       else {
6070       int trnend;
6071
6072         /* now we have foo:bar or foo:[000000]bar to decide from */
6073         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6074         trnend = islnm ? islnm - 1 : 0;
6075
6076         /* if this was a logical name, ']' or '>' must be present */
6077         /* if not a logical name, then assume a device and hope. */
6078         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6079
6080         /* if log name and trailing '.' then rooted - treat as device */
6081         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6082
6083         /* Fix me, if not a logical name, a device lookup should be
6084          * done to see if the device is file structured.  If the device
6085          * is not file structured, the 6 zeros should not be put on.
6086          *
6087          * As it is, perl is occasionally looking for dev:[000000]tty.
6088          * which looks a little strange.
6089          */
6090
6091         if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
6092           /* No real directory present */
6093           add_6zero = 1;
6094         }
6095       }
6096
6097       /* Put the device delimiter on */
6098       *vmsptr++ = ':';
6099       vmslen++;
6100       unixptr = nextslash;
6101       unixptr++;
6102
6103       /* Start directory if needed */
6104       if (!islnm || add_6zero) {
6105         *vmsptr++ = '[';
6106         vmslen++;
6107         dir_start = 1;
6108       }
6109
6110       /* add fake 000000] if needed */
6111       if (add_6zero) {
6112         *vmsptr++ = '0';
6113         *vmsptr++ = '0';
6114         *vmsptr++ = '0';
6115         *vmsptr++ = '0';
6116         *vmsptr++ = '0';
6117         *vmsptr++ = '0';
6118         *vmsptr++ = ']';
6119         vmslen += 7;
6120         dir_start = 0;
6121       }
6122
6123     } /* non-POSIX translation */
6124     PerlMem_free(esa);
6125   } /* End of relative/absolute path handling */
6126
6127   while ((*unixptr) && (vmslen < vmspath_len)){
6128   int dash_flag;
6129
6130     dash_flag = 0;
6131
6132     if (dir_start != 0) {
6133
6134       /* First characters in a directory are handled special */
6135       while ((*unixptr == '/') ||
6136              ((*unixptr == '.') &&
6137               ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
6138       int loop_flag;
6139
6140         loop_flag = 0;
6141
6142         /* Skip redundant / in specification */
6143         while ((*unixptr == '/') && (dir_start != 0)) {
6144           loop_flag = 1;
6145           unixptr++;
6146           if (unixptr == lastslash)
6147             break;
6148         }
6149         if (unixptr == lastslash)
6150           break;
6151
6152         /* Skip redundant ./ characters */
6153         while ((*unixptr == '.') &&
6154                ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
6155           loop_flag = 1;
6156           unixptr++;
6157           if (unixptr == lastslash)
6158             break;
6159           if (*unixptr == '/')
6160             unixptr++;
6161         }
6162         if (unixptr == lastslash)
6163           break;
6164
6165         /* Skip redundant ../ characters */
6166         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6167              ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
6168           /* Set the backing up flag */
6169           loop_flag = 1;
6170           dir_dot = 0;
6171           dash_flag = 1;
6172           *vmsptr++ = '-';
6173           vmslen++;
6174           unixptr++; /* first . */
6175           unixptr++; /* second . */
6176           if (unixptr == lastslash)
6177             break;
6178           if (*unixptr == '/') /* The slash */
6179             unixptr++;
6180         }
6181         if (unixptr == lastslash)
6182           break;
6183
6184         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6185         /* Not needed when VMS is pretending to be UNIX. */
6186
6187         /* Is this loop stuck because of too many dots? */
6188         if (loop_flag == 0) {
6189           /* Exit the loop and pass the rest through */
6190           break;
6191         }
6192       }
6193
6194       /* Are we done with directories yet? */
6195       if (unixptr >= lastslash) {
6196
6197         /* Watch out for trailing dots */
6198         if (dir_dot != 0) {
6199             vmslen --;
6200             vmsptr--;
6201         }
6202         *vmsptr++ = ']';
6203         vmslen++;
6204         dash_flag = 0;
6205         dir_start = 0;
6206         if (*unixptr == '/')
6207           unixptr++;
6208       }
6209       else {
6210         /* Have we stopped backing up? */
6211         if (dash_flag) {
6212           *vmsptr++ = '.';
6213           vmslen++;
6214           dash_flag = 0;
6215           /* dir_start continues to be = 1 */
6216         }
6217         if (*unixptr == '-') {
6218           *vmsptr++ = '^';
6219           *vmsptr++ = *unixptr++;
6220           vmslen += 2;
6221           dir_start = 0;
6222
6223           /* Now are we done with directories yet? */
6224           if (unixptr >= lastslash) {
6225
6226             /* Watch out for trailing dots */
6227             if (dir_dot != 0) {
6228               vmslen --;
6229               vmsptr--;
6230             }
6231
6232             *vmsptr++ = ']';
6233             vmslen++;
6234             dash_flag = 0;
6235             dir_start = 0;
6236           }
6237         }
6238       }
6239     }
6240
6241     /* All done? */
6242     if (*unixptr == '\0')
6243       break;
6244
6245     /* Normal characters - More EFS work probably needed */
6246     dir_start = 0;
6247     dir_dot = 0;
6248
6249     switch(*unixptr) {
6250     case '/':
6251         /* remove multiple / */
6252         while (unixptr[1] == '/') {
6253            unixptr++;
6254         }
6255         if (unixptr == lastslash) {
6256           /* Watch out for trailing dots */
6257           if (dir_dot != 0) {
6258             vmslen --;
6259             vmsptr--;
6260           }
6261           *vmsptr++ = ']';
6262         }
6263         else {
6264           dir_start = 1;
6265           *vmsptr++ = '.';
6266           dir_dot = 1;
6267
6268           /* To do: Perl expects /.../ to be translated to [...] on VMS */
6269           /* Not needed when VMS is pretending to be UNIX. */
6270
6271         }
6272         dash_flag = 0;
6273         if (*unixptr != '\0')
6274           unixptr++;
6275         vmslen++;
6276         break;
6277     case '?':
6278         *vmsptr++ = '%';
6279         vmslen++;
6280         unixptr++;
6281         break;
6282     case ' ':
6283         *vmsptr++ = '^';
6284         *vmsptr++ = '_';
6285         vmslen += 2;
6286         unixptr++;
6287         break;
6288     case '.':
6289         if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
6290           *vmsptr++ = '^';
6291           *vmsptr++ = '.';
6292           vmslen += 2;
6293           unixptr++;
6294
6295           /* trailing dot ==> '^..' on VMS */
6296           if (*unixptr == '\0') {
6297             *vmsptr++ = '.';
6298             vmslen++;
6299           }
6300           *vmsptr++ = *unixptr++;
6301           vmslen ++;
6302         }
6303         if (quoted && (unixptr[1] == '\0')) {
6304           unixptr++;
6305           break;
6306         }
6307         *vmsptr++ = '^';
6308         *vmsptr++ = *unixptr++;
6309         vmslen += 2;
6310         break;
6311     case '~':
6312     case ';':
6313     case '\\':
6314         *vmsptr++ = '^';
6315         *vmsptr++ = *unixptr++;
6316         vmslen += 2;
6317         break;
6318     default:
6319         if (*unixptr != '\0') {
6320           *vmsptr++ = *unixptr++;
6321           vmslen++;
6322         }
6323         break;
6324     }
6325   }
6326
6327   /* Make sure directory is closed */
6328   if (unixptr == lastslash) {
6329     char *vmsptr2;
6330     vmsptr2 = vmsptr - 1;
6331
6332     if (*vmsptr2 != ']') {
6333       *vmsptr2--;
6334
6335       /* directories do not end in a dot bracket */
6336       if (*vmsptr2 == '.') {
6337         vmsptr2--;
6338
6339         /* ^. is allowed */
6340         if (*vmsptr2 != '^') {
6341           vmsptr--; /* back up over the dot */
6342         }
6343       }
6344       *vmsptr++ = ']';
6345     }
6346   }
6347   else {
6348     char *vmsptr2;
6349     /* Add a trailing dot if a file with no extension */
6350     vmsptr2 = vmsptr - 1;
6351     if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6352         (*lastdot != '.')) {
6353         *vmsptr++ = '.';
6354         vmslen++;
6355     }
6356   }
6357
6358   *vmsptr = '\0';
6359   return SS$_NORMAL;
6360 }
6361 #endif
6362
6363 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6364 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6365   static char __tovmsspec_retbuf[VMS_MAXRSS];
6366   char *rslt, *dirend;
6367   char *lastdot;
6368   char *vms_delim;
6369   register char *cp1;
6370   const char *cp2;
6371   unsigned long int infront = 0, hasdir = 1;
6372   int rslt_len;
6373   int no_type_seen;
6374
6375   if (path == NULL) return NULL;
6376   rslt_len = VMS_MAXRSS;
6377   if (buf) rslt = buf;
6378   else if (ts) Newx(rslt, VMS_MAXRSS, char);
6379   else rslt = __tovmsspec_retbuf;
6380   if (strpbrk(path,"]:>") ||
6381       (dirend = strrchr(path,'/')) == NULL) {
6382     if (path[0] == '.') {
6383       if (path[1] == '\0') strcpy(rslt,"[]");
6384       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6385       else strcpy(rslt,path); /* probably garbage */
6386     }
6387     else strcpy(rslt,path);
6388     return rslt;
6389   }
6390
6391    /* Posix specifications are now a native VMS format */
6392   /*--------------------------------------------------*/
6393 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6394   if (decc_posix_compliant_pathnames) {
6395     if (strncmp(path,"\"^UP^",5) == 0) {
6396       posix_to_vmsspec_hardway(rslt, rslt_len, path);
6397       return rslt;
6398     }
6399   }
6400 #endif
6401
6402   vms_delim = strpbrk(path,"]:>");
6403
6404   if ((vms_delim != NULL) ||
6405       ((dirend = strrchr(path,'/')) == NULL)) {
6406
6407     /* VMS special characters found! */
6408
6409     if (path[0] == '.') {
6410       if (path[1] == '\0') strcpy(rslt,"[]");
6411       else if (path[1] == '.' && path[2] == '\0')
6412         strcpy(rslt,"[-]");
6413
6414       /* Dot preceeding a device or directory ? */
6415       else {
6416         /* If not in POSIX mode, pass it through and hope it works */
6417 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6418         if (!decc_posix_compliant_pathnames)
6419           strcpy(rslt,path); /* probably garbage */
6420         else
6421           posix_to_vmsspec_hardway(rslt, rslt_len, path);
6422 #else
6423         strcpy(rslt,path); /* probably garbage */
6424 #endif
6425       }
6426     }
6427     else {
6428
6429        /* If no VMS characters and in POSIX mode, convert it!
6430         * This is the easiest way to get directory specifications
6431         * handled correctly in POSIX mode
6432         */
6433 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6434       if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6435         posix_to_vmsspec_hardway(rslt, rslt_len, path);
6436       else {
6437         /* No unix path separators - presume VMS already */
6438         strcpy(rslt,path);
6439       }
6440 #else
6441       strcpy(rslt,path); /* probably garbage */
6442 #endif
6443     }
6444     return rslt;
6445   }
6446
6447 /* If POSIX mode active, handle the conversion */
6448 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6449   if (decc_posix_compliant_pathnames) {
6450     posix_to_vmsspec_hardway(rslt, rslt_len, path);
6451     return rslt;
6452   }
6453 #endif
6454
6455   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
6456     if (!*(dirend+2)) dirend +=2;
6457     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6458     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6459   }
6460
6461   cp1 = rslt;
6462   cp2 = path;
6463   lastdot = strrchr(cp2,'.');
6464   if (*cp2 == '/') {
6465     char *trndev;
6466     int islnm, rooted;
6467     STRLEN trnend;
6468
6469     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6470     if (!*(cp2+1)) {
6471       if (decc_disable_posix_root) {
6472         strcpy(rslt,"sys$disk:[000000]");
6473       }
6474       else {
6475         strcpy(rslt,"sys$posix_root:[000000]");
6476       }
6477       return rslt;
6478     }
6479     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6480     *cp1 = '\0';
6481     trndev = PerlMem_malloc(VMS_MAXRSS);
6482     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
6483     islnm =  my_trnlnm(rslt,trndev,0);
6484
6485      /* DECC special handling */
6486     if (!islnm) {
6487       if (strcmp(rslt,"bin") == 0) {
6488         strcpy(rslt,"sys$system");
6489         cp1 = rslt + 10;
6490         *cp1 = 0;
6491         islnm =  my_trnlnm(rslt,trndev,0);
6492       }
6493       else if (strcmp(rslt,"tmp") == 0) {
6494         strcpy(rslt,"sys$scratch");
6495         cp1 = rslt + 11;
6496         *cp1 = 0;
6497         islnm =  my_trnlnm(rslt,trndev,0);
6498       }
6499       else if (!decc_disable_posix_root) {
6500         strcpy(rslt, "sys$posix_root");
6501         cp1 = rslt + 13;
6502         *cp1 = 0;
6503         cp2 = path;
6504         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6505         islnm =  my_trnlnm(rslt,trndev,0);
6506       }
6507       else if (strcmp(rslt,"dev") == 0) {
6508         if (strncmp(cp2,"/null", 5) == 0) {
6509           if ((cp2[5] == 0) || (cp2[5] == '/')) {
6510             strcpy(rslt,"NLA0");
6511             cp1 = rslt + 4;
6512             *cp1 = 0;
6513             cp2 = cp2 + 5;
6514             islnm =  my_trnlnm(rslt,trndev,0);
6515           }
6516         }
6517       }
6518     }
6519
6520     trnend = islnm ? strlen(trndev) - 1 : 0;
6521     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6522     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6523     /* If the first element of the path is a logical name, determine
6524      * whether it has to be translated so we can add more directories. */
6525     if (!islnm || rooted) {
6526       *(cp1++) = ':';
6527       *(cp1++) = '[';
6528       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6529       else cp2++;
6530     }
6531     else {
6532       if (cp2 != dirend) {
6533         strcpy(rslt,trndev);
6534         cp1 = rslt + trnend;
6535         if (*cp2 != 0) {
6536           *(cp1++) = '.';
6537           cp2++;
6538         }
6539       }
6540       else {
6541         if (decc_disable_posix_root) {
6542           *(cp1++) = ':';
6543           hasdir = 0;
6544         }
6545       }
6546     }
6547     PerlMem_free(trndev);
6548   }
6549   else {
6550     *(cp1++) = '[';
6551     if (*cp2 == '.') {
6552       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6553         cp2 += 2;         /* skip over "./" - it's redundant */
6554         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
6555       }
6556       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6557         *(cp1++) = '-';                                 /* "../" --> "-" */
6558         cp2 += 3;
6559       }
6560       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6561                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6562         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6563         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6564         cp2 += 4;
6565       }
6566       else if ((cp2 != lastdot) || (lastdot < dirend)) {
6567         /* Escape the extra dots in EFS file specifications */
6568         *(cp1++) = '^';
6569       }
6570       if (cp2 > dirend) cp2 = dirend;
6571     }
6572     else *(cp1++) = '.';
6573   }
6574   for (; cp2 < dirend; cp2++) {
6575     if (*cp2 == '/') {
6576       if (*(cp2-1) == '/') continue;
6577       if (*(cp1-1) != '.') *(cp1++) = '.';
6578       infront = 0;
6579     }
6580     else if (!infront && *cp2 == '.') {
6581       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6582       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
6583       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6584         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6585         else if (*(cp1-2) == '[') *(cp1-1) = '-';
6586         else {  /* back up over previous directory name */
6587           cp1--;
6588           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6589           if (*(cp1-1) == '[') {
6590             memcpy(cp1,"000000.",7);
6591             cp1 += 7;
6592           }
6593         }
6594         cp2 += 2;
6595         if (cp2 == dirend) break;
6596       }
6597       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6598                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6599         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6600         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6601         if (!*(cp2+3)) {
6602           *(cp1++) = '.';  /* Simulate trailing '/' */
6603           cp2 += 2;  /* for loop will incr this to == dirend */
6604         }
6605         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
6606       }
6607       else {
6608         if (decc_efs_charset == 0)
6609           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
6610         else {
6611           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
6612           *(cp1++) = '.';
6613         }
6614       }
6615     }
6616     else {
6617       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
6618       if (*cp2 == '.') {
6619         if (decc_efs_charset == 0)
6620           *(cp1++) = '_';
6621         else {
6622           *(cp1++) = '^';
6623           *(cp1++) = '.';
6624         }
6625       }
6626       else                  *(cp1++) =  *cp2;
6627       infront = 1;
6628     }
6629   }
6630   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6631   if (hasdir) *(cp1++) = ']';
6632   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
6633   /* fixme for ODS5 */
6634   no_type_seen = 0;
6635   if (cp2 > lastdot)
6636     no_type_seen = 1;
6637   while (*cp2) {
6638     switch(*cp2) {
6639     case '?':
6640         *(cp1++) = '%';
6641         cp2++;
6642     case ' ':
6643         *(cp1)++ = '^';
6644         *(cp1)++ = '_';
6645         cp2++;
6646         break;
6647     case '.':
6648         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6649             decc_readdir_dropdotnotype) {
6650           *(cp1)++ = '^';
6651           *(cp1)++ = '.';
6652           cp2++;
6653
6654           /* trailing dot ==> '^..' on VMS */
6655           if (*cp2 == '\0') {
6656             *(cp1++) = '.';
6657             no_type_seen = 0;
6658           }
6659         }
6660         else {
6661           *(cp1++) = *(cp2++);
6662           no_type_seen = 0;
6663         }
6664         break;
6665     case '\"':
6666     case '~':
6667     case '`':
6668     case '!':
6669     case '#':
6670     case '%':
6671     case '^':
6672     case '&':
6673     case '(':
6674     case ')':
6675     case '=':
6676     case '+':
6677     case '\'':
6678     case '@':
6679     case '[':
6680     case ']':
6681     case '{':
6682     case '}':
6683     case ':':
6684     case '\\':
6685     case '|':
6686     case '<':
6687     case '>':
6688         *(cp1++) = '^';
6689         *(cp1++) = *(cp2++);
6690         break;
6691     case ';':
6692         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6693          * which is wrong.  UNIX notation should be ".dir." unless
6694          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6695          * changing this behavior could break more things at this time.
6696          * efs character set effectively does not allow "." to be a version
6697          * delimiter as a further complication about changing this.
6698          */
6699         if (decc_filename_unix_report != 0) {
6700           *(cp1++) = '^';
6701         }
6702         *(cp1++) = *(cp2++);
6703         break;
6704     default:
6705         *(cp1++) = *(cp2++);
6706     }
6707   }
6708   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6709   char *lcp1;
6710     lcp1 = cp1;
6711     lcp1--;
6712      /* Fix me for "^]", but that requires making sure that you do
6713       * not back up past the start of the filename
6714       */
6715     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6716       *cp1++ = '.';
6717   }
6718   *cp1 = '\0';
6719
6720   return rslt;
6721
6722 }  /* end of do_tovmsspec() */
6723 /*}}}*/
6724 /* External entry points */
6725 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6726 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6727
6728 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6729 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6730   static char __tovmspath_retbuf[VMS_MAXRSS];
6731   int vmslen;
6732   char *pathified, *vmsified, *cp;
6733
6734   if (path == NULL) return NULL;
6735   pathified = PerlMem_malloc(VMS_MAXRSS);
6736   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
6737   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6738     PerlMem_free(pathified);
6739     return NULL;
6740   }
6741
6742   vmsified = NULL;
6743   if (buf == NULL)
6744      Newx(vmsified, VMS_MAXRSS, char);
6745   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0) == NULL) {
6746     PerlMem_free(pathified);
6747     if (vmsified) Safefree(vmsified);
6748     return NULL;
6749   }
6750   PerlMem_free(pathified);
6751   if (buf) {
6752     return buf;
6753   }
6754   else if (ts) {
6755     vmslen = strlen(vmsified);
6756     Newx(cp,vmslen+1,char);
6757     memcpy(cp,vmsified,vmslen);
6758     cp[vmslen] = '\0';
6759     Safefree(vmsified);
6760     return cp;
6761   }
6762   else {
6763     strcpy(__tovmspath_retbuf,vmsified);
6764     Safefree(vmsified);
6765     return __tovmspath_retbuf;
6766   }
6767
6768 }  /* end of do_tovmspath() */
6769 /*}}}*/
6770 /* External entry points */
6771 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6772 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6773
6774
6775 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6776 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6777   static char __tounixpath_retbuf[VMS_MAXRSS];
6778   int unixlen;
6779   char *pathified, *unixified, *cp;
6780
6781   if (path == NULL) return NULL;
6782   pathified = PerlMem_malloc(VMS_MAXRSS);
6783   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
6784   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6785     PerlMem_free(pathified);
6786     return NULL;
6787   }
6788
6789   unixified = NULL;
6790   if (buf == NULL) {
6791       Newx(unixified, VMS_MAXRSS, char);
6792   }
6793   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6794     PerlMem_free(pathified);
6795     if (unixified) Safefree(unixified);
6796     return NULL;
6797   }
6798   PerlMem_free(pathified);
6799   if (buf) {
6800     return buf;
6801   }
6802   else if (ts) {
6803     unixlen = strlen(unixified);
6804     Newx(cp,unixlen+1,char);
6805     memcpy(cp,unixified,unixlen);
6806     cp[unixlen] = '\0';
6807     Safefree(unixified);
6808     return cp;
6809   }
6810   else {
6811     strcpy(__tounixpath_retbuf,unixified);
6812     Safefree(unixified);
6813     return __tounixpath_retbuf;
6814   }
6815
6816 }  /* end of do_tounixpath() */
6817 /*}}}*/
6818 /* External entry points */
6819 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6820 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6821
6822 /*
6823  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
6824  *
6825  *****************************************************************************
6826  *                                                                           *
6827  *  Copyright (C) 1989-1994 by                                               *
6828  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
6829  *                                                                           *
6830  *  Permission is hereby  granted for the reproduction of this software,     *
6831  *  on condition that this copyright notice is included in the reproduction, *
6832  *  and that such reproduction is not for purposes of profit or material     *
6833  *  gain.                                                                    *
6834  *                                                                           *
6835  *  27-Aug-1994 Modified for inclusion in perl5                              *
6836  *              by Charles Bailey  bailey@newman.upenn.edu                   *
6837  *****************************************************************************
6838  */
6839
6840 /*
6841  * getredirection() is intended to aid in porting C programs
6842  * to VMS (Vax-11 C).  The native VMS environment does not support
6843  * '>' and '<' I/O redirection, or command line wild card expansion,
6844  * or a command line pipe mechanism using the '|' AND background
6845  * command execution '&'.  All of these capabilities are provided to any
6846  * C program which calls this procedure as the first thing in the
6847  * main program.
6848  * The piping mechanism will probably work with almost any 'filter' type
6849  * of program.  With suitable modification, it may useful for other
6850  * portability problems as well.
6851  *
6852  * Author:  Mark Pizzolato      mark@infocomm.com
6853  */
6854 struct list_item
6855     {
6856     struct list_item *next;
6857     char *value;
6858     };
6859
6860 static void add_item(struct list_item **head,
6861                      struct list_item **tail,
6862                      char *value,
6863                      int *count);
6864
6865 static void mp_expand_wild_cards(pTHX_ char *item,
6866                                 struct list_item **head,
6867                                 struct list_item **tail,
6868                                 int *count);
6869
6870 static int background_process(pTHX_ int argc, char **argv);
6871
6872 static void pipe_and_fork(pTHX_ char **cmargv);
6873
6874 /*{{{ void getredirection(int *ac, char ***av)*/
6875 static void
6876 mp_getredirection(pTHX_ int *ac, char ***av)
6877 /*
6878  * Process vms redirection arg's.  Exit if any error is seen.
6879  * If getredirection() processes an argument, it is erased
6880  * from the vector.  getredirection() returns a new argc and argv value.
6881  * In the event that a background command is requested (by a trailing "&"),
6882  * this routine creates a background subprocess, and simply exits the program.
6883  *
6884  * Warning: do not try to simplify the code for vms.  The code
6885  * presupposes that getredirection() is called before any data is
6886  * read from stdin or written to stdout.
6887  *
6888  * Normal usage is as follows:
6889  *
6890  *      main(argc, argv)
6891  *      int             argc;
6892  *      char            *argv[];
6893  *      {
6894  *              getredirection(&argc, &argv);
6895  *      }
6896  */
6897 {
6898     int                 argc = *ac;     /* Argument Count         */
6899     char                **argv = *av;   /* Argument Vector        */
6900     char                *ap;            /* Argument pointer       */
6901     int                 j;              /* argv[] index           */
6902     int                 item_count = 0; /* Count of Items in List */
6903     struct list_item    *list_head = 0; /* First Item in List       */
6904     struct list_item    *list_tail;     /* Last Item in List        */
6905     char                *in = NULL;     /* Input File Name          */
6906     char                *out = NULL;    /* Output File Name         */
6907     char                *outmode = "w"; /* Mode to Open Output File */
6908     char                *err = NULL;    /* Error File Name          */
6909     char                *errmode = "w"; /* Mode to Open Error File  */
6910     int                 cmargc = 0;     /* Piped Command Arg Count  */
6911     char                **cmargv = NULL;/* Piped Command Arg Vector */
6912
6913     /*
6914      * First handle the case where the last thing on the line ends with
6915      * a '&'.  This indicates the desire for the command to be run in a
6916      * subprocess, so we satisfy that desire.
6917      */
6918     ap = argv[argc-1];
6919     if (0 == strcmp("&", ap))
6920        exit(background_process(aTHX_ --argc, argv));
6921     if (*ap && '&' == ap[strlen(ap)-1])
6922         {
6923         ap[strlen(ap)-1] = '\0';
6924        exit(background_process(aTHX_ argc, argv));
6925         }
6926     /*
6927      * Now we handle the general redirection cases that involve '>', '>>',
6928      * '<', and pipes '|'.
6929      */
6930     for (j = 0; j < argc; ++j)
6931         {
6932         if (0 == strcmp("<", argv[j]))
6933             {
6934             if (j+1 >= argc)
6935                 {
6936                 fprintf(stderr,"No input file after < on command line");
6937                 exit(LIB$_WRONUMARG);
6938                 }
6939             in = argv[++j];
6940             continue;
6941             }
6942         if ('<' == *(ap = argv[j]))
6943             {
6944             in = 1 + ap;
6945             continue;
6946             }
6947         if (0 == strcmp(">", ap))
6948             {
6949             if (j+1 >= argc)
6950                 {
6951                 fprintf(stderr,"No output file after > on command line");
6952                 exit(LIB$_WRONUMARG);
6953                 }
6954             out = argv[++j];
6955             continue;
6956             }
6957         if ('>' == *ap)
6958             {
6959             if ('>' == ap[1])
6960                 {
6961                 outmode = "a";
6962                 if ('\0' == ap[2])
6963                     out = argv[++j];
6964                 else
6965                     out = 2 + ap;
6966                 }
6967             else
6968                 out = 1 + ap;
6969             if (j >= argc)
6970                 {
6971                 fprintf(stderr,"No output file after > or >> on command line");
6972                 exit(LIB$_WRONUMARG);
6973                 }
6974             continue;
6975             }
6976         if (('2' == *ap) && ('>' == ap[1]))
6977             {
6978             if ('>' == ap[2])
6979                 {
6980                 errmode = "a";
6981                 if ('\0' == ap[3])
6982                     err = argv[++j];
6983                 else
6984                     err = 3 + ap;
6985                 }
6986             else
6987                 if ('\0' == ap[2])
6988                     err = argv[++j];
6989                 else
6990                     err = 2 + ap;
6991             if (j >= argc)
6992                 {
6993                 fprintf(stderr,"No output file after 2> or 2>> on command line");
6994                 exit(LIB$_WRONUMARG);
6995                 }
6996             continue;
6997             }
6998         if (0 == strcmp("|", argv[j]))
6999             {
7000             if (j+1 >= argc)
7001                 {
7002                 fprintf(stderr,"No command into which to pipe on command line");
7003                 exit(LIB$_WRONUMARG);
7004                 }
7005             cmargc = argc-(j+1);
7006             cmargv = &argv[j+1];
7007             argc = j;
7008             continue;
7009             }
7010         if ('|' == *(ap = argv[j]))
7011             {
7012             ++argv[j];
7013             cmargc = argc-j;
7014             cmargv = &argv[j];
7015             argc = j;
7016             continue;
7017             }
7018         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7019         }
7020     /*
7021      * Allocate and fill in the new argument vector, Some Unix's terminate
7022      * the list with an extra null pointer.
7023      */
7024     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7025     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7026     *av = argv;
7027     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7028         argv[j] = list_head->value;
7029     *ac = item_count;
7030     if (cmargv != NULL)
7031         {
7032         if (out != NULL)
7033             {
7034             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7035             exit(LIB$_INVARGORD);
7036             }
7037         pipe_and_fork(aTHX_ cmargv);
7038         }
7039
7040     /* Check for input from a pipe (mailbox) */
7041
7042     if (in == NULL && 1 == isapipe(0))
7043         {
7044         char mbxname[L_tmpnam];
7045         long int bufsize;
7046         long int dvi_item = DVI$_DEVBUFSIZ;
7047         $DESCRIPTOR(mbxnam, "");
7048         $DESCRIPTOR(mbxdevnam, "");
7049
7050         /* Input from a pipe, reopen it in binary mode to disable       */
7051         /* carriage control processing.                                 */
7052
7053         fgetname(stdin, mbxname);
7054         mbxnam.dsc$a_pointer = mbxname;
7055         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7056         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7057         mbxdevnam.dsc$a_pointer = mbxname;
7058         mbxdevnam.dsc$w_length = sizeof(mbxname);
7059         dvi_item = DVI$_DEVNAM;
7060         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7061         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7062         set_errno(0);
7063         set_vaxc_errno(1);
7064         freopen(mbxname, "rb", stdin);
7065         if (errno != 0)
7066             {
7067             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7068             exit(vaxc$errno);
7069             }
7070         }
7071     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7072         {
7073         fprintf(stderr,"Can't open input file %s as stdin",in);
7074         exit(vaxc$errno);
7075         }
7076     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7077         {
7078         fprintf(stderr,"Can't open output file %s as stdout",out);
7079         exit(vaxc$errno);
7080         }
7081         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7082
7083     if (err != NULL) {
7084         if (strcmp(err,"&1") == 0) {
7085             dup2(fileno(stdout), fileno(stderr));
7086             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7087         } else {
7088         FILE *tmperr;
7089         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7090             {
7091             fprintf(stderr,"Can't open error file %s as stderr",err);
7092             exit(vaxc$errno);
7093             }
7094             fclose(tmperr);
7095            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7096                 {
7097                 exit(vaxc$errno);
7098                 }
7099             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7100         }
7101         }
7102 #ifdef ARGPROC_DEBUG
7103     PerlIO_printf(Perl_debug_log, "Arglist:\n");
7104     for (j = 0; j < *ac;  ++j)
7105         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7106 #endif
7107    /* Clear errors we may have hit expanding wildcards, so they don't
7108       show up in Perl's $! later */
7109    set_errno(0); set_vaxc_errno(1);
7110 }  /* end of getredirection() */
7111 /*}}}*/
7112
7113 static void add_item(struct list_item **head,
7114                      struct list_item **tail,
7115                      char *value,
7116                      int *count)
7117 {
7118     if (*head == 0)
7119         {
7120         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7121         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7122         *tail = *head;
7123         }
7124     else {
7125         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7126         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7127         *tail = (*tail)->next;
7128         }
7129     (*tail)->value = value;
7130     ++(*count);
7131 }
7132
7133 static void mp_expand_wild_cards(pTHX_ char *item,
7134                               struct list_item **head,
7135                               struct list_item **tail,
7136                               int *count)
7137 {
7138 int expcount = 0;
7139 unsigned long int context = 0;
7140 int isunix = 0;
7141 int item_len = 0;
7142 char *had_version;
7143 char *had_device;
7144 int had_directory;
7145 char *devdir,*cp;
7146 char *vmsspec;
7147 $DESCRIPTOR(filespec, "");
7148 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7149 $DESCRIPTOR(resultspec, "");
7150 unsigned long int lff_flags = 0;
7151 int sts;
7152 int rms_sts;
7153
7154 #ifdef VMS_LONGNAME_SUPPORT
7155     lff_flags = LIB$M_FIL_LONG_NAMES;
7156 #endif
7157
7158     for (cp = item; *cp; cp++) {
7159         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7160         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7161     }
7162     if (!*cp || isspace(*cp))
7163         {
7164         add_item(head, tail, item, count);
7165         return;
7166         }
7167     else
7168         {
7169      /* "double quoted" wild card expressions pass as is */
7170      /* From DCL that means using e.g.:                  */
7171      /* perl program """perl.*"""                        */
7172      item_len = strlen(item);
7173      if ( '"' == *item && '"' == item[item_len-1] )
7174        {
7175        item++;
7176        item[item_len-2] = '\0';
7177        add_item(head, tail, item, count);
7178        return;
7179        }
7180      }
7181     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7182     resultspec.dsc$b_class = DSC$K_CLASS_D;
7183     resultspec.dsc$a_pointer = NULL;
7184     vmsspec = PerlMem_malloc(VMS_MAXRSS);
7185     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7186     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7187       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
7188     if (!isunix || !filespec.dsc$a_pointer)
7189       filespec.dsc$a_pointer = item;
7190     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7191     /*
7192      * Only return version specs, if the caller specified a version
7193      */
7194     had_version = strchr(item, ';');
7195     /*
7196      * Only return device and directory specs, if the caller specifed either.
7197      */
7198     had_device = strchr(item, ':');
7199     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7200
7201     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7202                                  (&filespec, &resultspec, &context,
7203                                   &defaultspec, 0, &rms_sts, &lff_flags)))
7204         {
7205         char *string;
7206         char *c;
7207
7208         string = PerlMem_malloc(resultspec.dsc$w_length+1);
7209         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7210         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7211         string[resultspec.dsc$w_length] = '\0';
7212         if (NULL == had_version)
7213             *(strrchr(string, ';')) = '\0';
7214         if ((!had_directory) && (had_device == NULL))
7215             {
7216             if (NULL == (devdir = strrchr(string, ']')))
7217                 devdir = strrchr(string, '>');
7218             strcpy(string, devdir + 1);
7219             }
7220         /*
7221          * Be consistent with what the C RTL has already done to the rest of
7222          * the argv items and lowercase all of these names.
7223          */
7224         if (!decc_efs_case_preserve) {
7225             for (c = string; *c; ++c)
7226             if (isupper(*c))
7227                 *c = tolower(*c);
7228         }
7229         if (isunix) trim_unixpath(string,item,1);
7230         add_item(head, tail, string, count);
7231         ++expcount;
7232     }
7233     PerlMem_free(vmsspec);
7234     if (sts != RMS$_NMF)
7235         {
7236         set_vaxc_errno(sts);
7237         switch (sts)
7238             {
7239             case RMS$_FNF: case RMS$_DNF:
7240                 set_errno(ENOENT); break;
7241             case RMS$_DIR:
7242                 set_errno(ENOTDIR); break;
7243             case RMS$_DEV:
7244                 set_errno(ENODEV); break;
7245             case RMS$_FNM: case RMS$_SYN:
7246                 set_errno(EINVAL); break;
7247             case RMS$_PRV:
7248                 set_errno(EACCES); break;
7249             default:
7250                 _ckvmssts_noperl(sts);
7251             }
7252         }
7253     if (expcount == 0)
7254         add_item(head, tail, item, count);
7255     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7256     _ckvmssts_noperl(lib$find_file_end(&context));
7257 }
7258
7259 static int child_st[2];/* Event Flag set when child process completes   */
7260
7261 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
7262
7263 static unsigned long int exit_handler(int *status)
7264 {
7265 short iosb[4];
7266
7267     if (0 == child_st[0])
7268         {
7269 #ifdef ARGPROC_DEBUG
7270         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7271 #endif
7272         fflush(stdout);     /* Have to flush pipe for binary data to    */
7273                             /* terminate properly -- <tp@mccall.com>    */
7274         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7275         sys$dassgn(child_chan);
7276         fclose(stdout);
7277         sys$synch(0, child_st);
7278         }
7279     return(1);
7280 }
7281
7282 static void sig_child(int chan)
7283 {
7284 #ifdef ARGPROC_DEBUG
7285     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7286 #endif
7287     if (child_st[0] == 0)
7288         child_st[0] = 1;
7289 }
7290
7291 static struct exit_control_block exit_block =
7292     {
7293     0,
7294     exit_handler,
7295     1,
7296     &exit_block.exit_status,
7297     0
7298     };
7299
7300 static void
7301 pipe_and_fork(pTHX_ char **cmargv)
7302 {
7303     PerlIO *fp;
7304     struct dsc$descriptor_s *vmscmd;
7305     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7306     int sts, j, l, ismcr, quote, tquote = 0;
7307
7308     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
7309     vms_execfree(vmscmd);
7310
7311     j = l = 0;
7312     p = subcmd;
7313     q = cmargv[0];
7314     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
7315               && toupper(*(q+2)) == 'R' && !*(q+3);
7316
7317     while (q && l < MAX_DCL_LINE_LENGTH) {
7318         if (!*q) {
7319             if (j > 0 && quote) {
7320                 *p++ = '"';
7321                 l++;
7322             }
7323             q = cmargv[++j];
7324             if (q) {
7325                 if (ismcr && j > 1) quote = 1;
7326                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
7327                 *p++ = ' ';
7328                 l++;
7329                 if (quote || tquote) {
7330                     *p++ = '"';
7331                     l++;
7332                 }
7333         }
7334         } else {
7335             if ((quote||tquote) && *q == '"') {
7336                 *p++ = '"';
7337                 l++;
7338         }
7339             *p++ = *q++;
7340             l++;
7341         }
7342     }
7343     *p = '\0';
7344
7345     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7346     if (fp == Nullfp) {
7347         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7348         }
7349 }
7350
7351 static int background_process(pTHX_ int argc, char **argv)
7352 {
7353 char command[MAX_DCL_SYMBOL + 1] = "$";
7354 $DESCRIPTOR(value, "");
7355 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7356 static $DESCRIPTOR(null, "NLA0:");
7357 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7358 char pidstring[80];
7359 $DESCRIPTOR(pidstr, "");
7360 int pid;
7361 unsigned long int flags = 17, one = 1, retsts;
7362 int len;
7363
7364     strcat(command, argv[0]);
7365     len = strlen(command);
7366     while (--argc && (len < MAX_DCL_SYMBOL))
7367         {
7368         strcat(command, " \"");
7369         strcat(command, *(++argv));
7370         strcat(command, "\"");
7371         len = strlen(command);
7372         }
7373     value.dsc$a_pointer = command;
7374     value.dsc$w_length = strlen(value.dsc$a_pointer);
7375     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7376     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7377     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7378         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7379     }
7380     else {
7381         _ckvmssts_noperl(retsts);
7382     }
7383 #ifdef ARGPROC_DEBUG
7384     PerlIO_printf(Perl_debug_log, "%s\n", command);
7385 #endif
7386     sprintf(pidstring, "%08X", pid);
7387     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7388     pidstr.dsc$a_pointer = pidstring;
7389     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7390     lib$set_symbol(&pidsymbol, &pidstr);
7391     return(SS$_NORMAL);
7392 }
7393 /*}}}*/
7394 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7395
7396
7397 /* OS-specific initialization at image activation (not thread startup) */
7398 /* Older VAXC header files lack these constants */
7399 #ifndef JPI$_RIGHTS_SIZE
7400 #  define JPI$_RIGHTS_SIZE 817
7401 #endif
7402 #ifndef KGB$M_SUBSYSTEM
7403 #  define KGB$M_SUBSYSTEM 0x8
7404 #endif
7405
7406 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7407
7408 /*{{{void vms_image_init(int *, char ***)*/
7409 void
7410 vms_image_init(int *argcp, char ***argvp)
7411 {
7412   char eqv[LNM$C_NAMLENGTH+1] = "";
7413   unsigned int len, tabct = 8, tabidx = 0;
7414   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7415   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7416   unsigned short int dummy, rlen;
7417   struct dsc$descriptor_s **tabvec;
7418 #if defined(PERL_IMPLICIT_CONTEXT)
7419   pTHX = NULL;
7420 #endif
7421   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
7422                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
7423                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7424                                  {          0,                0,    0,      0} };
7425
7426 #ifdef KILL_BY_SIGPRC
7427     Perl_csighandler_init();
7428 #endif
7429
7430   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7431   _ckvmssts_noperl(iosb[0]);
7432   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7433     if (iprv[i]) {           /* Running image installed with privs? */
7434       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
7435       will_taint = TRUE;
7436       break;
7437     }
7438   }
7439   /* Rights identifiers might trigger tainting as well. */
7440   if (!will_taint && (rlen || rsz)) {
7441     while (rlen < rsz) {
7442       /* We didn't get all the identifiers on the first pass.  Allocate a
7443        * buffer much larger than $GETJPI wants (rsz is size in bytes that
7444        * were needed to hold all identifiers at time of last call; we'll
7445        * allocate that many unsigned long ints), and go back and get 'em.
7446        * If it gave us less than it wanted to despite ample buffer space,
7447        * something's broken.  Is your system missing a system identifier?
7448        */
7449       if (rsz <= jpilist[1].buflen) {
7450          /* Perl_croak accvios when used this early in startup. */
7451          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7452                          rsz, (unsigned long) jpilist[1].buflen,
7453                          "Check your rights database for corruption.\n");
7454          exit(SS$_ABORT);
7455       }
7456       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7457       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7458       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7459       jpilist[1].buflen = rsz * sizeof(unsigned long int);
7460       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7461       _ckvmssts_noperl(iosb[0]);
7462     }
7463     mask = jpilist[1].bufadr;
7464     /* Check attribute flags for each identifier (2nd longword); protected
7465      * subsystem identifiers trigger tainting.
7466      */
7467     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7468       if (mask[i] & KGB$M_SUBSYSTEM) {
7469         will_taint = TRUE;
7470         break;
7471       }
7472     }
7473     if (mask != rlst) PerlMem_free(mask);
7474   }
7475
7476   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7477    * logical, some versions of the CRTL will add a phanthom /000000/
7478    * directory.  This needs to be removed.
7479    */
7480   if (decc_filename_unix_report) {
7481   char * zeros;
7482   int ulen;
7483     ulen = strlen(argvp[0][0]);
7484     if (ulen > 7) {
7485       zeros = strstr(argvp[0][0], "/000000/");
7486       if (zeros != NULL) {
7487         int mlen;
7488         mlen = ulen - (zeros - argvp[0][0]) - 7;
7489         memmove(zeros, &zeros[7], mlen);
7490         ulen = ulen - 7;
7491         argvp[0][0][ulen] = '\0';
7492       }
7493     }
7494     /* It also may have a trailing dot that needs to be removed otherwise
7495      * it will be converted to VMS mode incorrectly.
7496      */
7497     ulen--;
7498     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7499       argvp[0][0][ulen] = '\0';
7500   }
7501
7502   /* We need to use this hack to tell Perl it should run with tainting,
7503    * since its tainting flag may be part of the PL_curinterp struct, which
7504    * hasn't been allocated when vms_image_init() is called.
7505    */
7506   if (will_taint) {
7507     char **newargv, **oldargv;
7508     oldargv = *argvp;
7509     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7510     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7511     newargv[0] = oldargv[0];
7512     newargv[1] = PerlMem_malloc(3 * sizeof(char));
7513     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7514     strcpy(newargv[1], "-T");
7515     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7516     (*argcp)++;
7517     newargv[*argcp] = NULL;
7518     /* We orphan the old argv, since we don't know where it's come from,
7519      * so we don't know how to free it.
7520      */
7521     *argvp = newargv;
7522   }
7523   else {  /* Did user explicitly request tainting? */
7524     int i;
7525     char *cp, **av = *argvp;
7526     for (i = 1; i < *argcp; i++) {
7527       if (*av[i] != '-') break;
7528       for (cp = av[i]+1; *cp; cp++) {
7529         if (*cp == 'T') { will_taint = 1; break; }
7530         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7531                   strchr("DFIiMmx",*cp)) break;
7532       }
7533       if (will_taint) break;
7534     }
7535   }
7536
7537   for (tabidx = 0;
7538        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7539        tabidx++) {
7540     if (!tabidx) {
7541       tabvec = (struct dsc$descriptor_s **)
7542             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7543       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7544     }
7545     else if (tabidx >= tabct) {
7546       tabct += 8;
7547       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7548       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7549     }
7550     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7551     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7552     tabvec[tabidx]->dsc$w_length  = 0;
7553     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
7554     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
7555     tabvec[tabidx]->dsc$a_pointer = NULL;
7556     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7557   }
7558   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7559
7560   getredirection(argcp,argvp);
7561 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7562   {
7563 # include <reentrancy.h>
7564   decc$set_reentrancy(C$C_MULTITHREAD);
7565   }
7566 #endif
7567   return;
7568 }
7569 /*}}}*/
7570
7571
7572 /* trim_unixpath()
7573  * Trim Unix-style prefix off filespec, so it looks like what a shell
7574  * glob expansion would return (i.e. from specified prefix on, not
7575  * full path).  Note that returned filespec is Unix-style, regardless
7576  * of whether input filespec was VMS-style or Unix-style.
7577  *
7578  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7579  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
7580  * vector of options; at present, only bit 0 is used, and if set tells
7581  * trim unixpath to try the current default directory as a prefix when
7582  * presented with a possibly ambiguous ... wildcard.
7583  *
7584  * Returns !=0 on success, with trimmed filespec replacing contents of
7585  * fspec, and 0 on failure, with contents of fpsec unchanged.
7586  */
7587 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7588 int
7589 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7590 {
7591   char *unixified, *unixwild,
7592        *template, *base, *end, *cp1, *cp2;
7593   register int tmplen, reslen = 0, dirs = 0;
7594
7595   unixwild = PerlMem_malloc(VMS_MAXRSS);
7596   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
7597   if (!wildspec || !fspec) return 0;
7598   template = unixwild;
7599   if (strpbrk(wildspec,"]>:") != NULL) {
7600     if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7601         PerlMem_free(unixwild);
7602         return 0;
7603     }
7604   }
7605   else {
7606     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7607     unixwild[VMS_MAXRSS-1] = 0;
7608   }
7609   unixified = PerlMem_malloc(VMS_MAXRSS);
7610   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
7611   if (strpbrk(fspec,"]>:") != NULL) {
7612     if (do_tounixspec(fspec,unixified,0) == NULL) {
7613         PerlMem_free(unixwild);
7614         PerlMem_free(unixified);
7615         return 0;
7616     }
7617     else base = unixified;
7618     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7619      * check to see that final result fits into (isn't longer than) fspec */
7620     reslen = strlen(fspec);
7621   }
7622   else base = fspec;
7623
7624   /* No prefix or absolute path on wildcard, so nothing to remove */
7625   if (!*template || *template == '/') {
7626     PerlMem_free(unixwild);
7627     if (base == fspec) {
7628         PerlMem_free(unixified);
7629         return 1;
7630     }
7631     tmplen = strlen(unixified);
7632     if (tmplen > reslen) {
7633         PerlMem_free(unixified);
7634         return 0;  /* not enough space */
7635     }
7636     /* Copy unixified resultant, including trailing NUL */
7637     memmove(fspec,unixified,tmplen+1);
7638     PerlMem_free(unixified);
7639     return 1;
7640   }
7641
7642   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
7643   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7644     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7645     for (cp1 = end ;cp1 >= base; cp1--)
7646       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7647         { cp1++; break; }
7648     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7649     PerlMem_free(unixified);
7650     PerlMem_free(unixwild);
7651     return 1;
7652   }
7653   else {
7654     char *tpl, *lcres;
7655     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7656     int ells = 1, totells, segdirs, match;
7657     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7658                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7659
7660     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7661     totells = ells;
7662     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7663     tpl = PerlMem_malloc(VMS_MAXRSS);
7664     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
7665     if (ellipsis == template && opts & 1) {
7666       /* Template begins with an ellipsis.  Since we can't tell how many
7667        * directory names at the front of the resultant to keep for an
7668        * arbitrary starting point, we arbitrarily choose the current
7669        * default directory as a starting point.  If it's there as a prefix,
7670        * clip it off.  If not, fall through and act as if the leading
7671        * ellipsis weren't there (i.e. return shortest possible path that
7672        * could match template).
7673        */
7674       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7675           PerlMem_free(tpl);
7676           PerlMem_free(unixified);
7677           PerlMem_free(unixwild);
7678           return 0;
7679       }
7680       if (!decc_efs_case_preserve) {
7681         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7682           if (_tolower(*cp1) != _tolower(*cp2)) break;
7683       }
7684       segdirs = dirs - totells;  /* Min # of dirs we must have left */
7685       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7686       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7687         memmove(fspec,cp2+1,end - cp2);
7688         PerlMem_free(tpl);
7689         PerlMem_free(unixified);
7690         PerlMem_free(unixwild);
7691         return 1;
7692       }
7693     }
7694     /* First off, back up over constant elements at end of path */
7695     if (dirs) {
7696       for (front = end ; front >= base; front--)
7697          if (*front == '/' && !dirs--) { front++; break; }
7698     }
7699     lcres = PerlMem_malloc(VMS_MAXRSS);
7700     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
7701     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7702          cp1++,cp2++) {
7703             if (!decc_efs_case_preserve) {
7704                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
7705             }
7706             else {
7707                 *cp2 = *cp1;
7708             }
7709     }
7710     if (cp1 != '\0') {
7711         PerlMem_free(tpl);
7712         PerlMem_free(unixified);
7713         PerlMem_free(unixwild);
7714         PerlMem_free(lcres);
7715         return 0;  /* Path too long. */
7716     }
7717     lcend = cp2;
7718     *cp2 = '\0';  /* Pick up with memcpy later */
7719     lcfront = lcres + (front - base);
7720     /* Now skip over each ellipsis and try to match the path in front of it. */
7721     while (ells--) {
7722       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7723         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
7724             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
7725       if (cp1 < template) break; /* template started with an ellipsis */
7726       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7727         ellipsis = cp1; continue;
7728       }
7729       wilddsc.dsc$a_pointer = tpl;
7730       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7731       nextell = cp1;
7732       for (segdirs = 0, cp2 = tpl;
7733            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7734            cp1++, cp2++) {
7735          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7736          else {
7737             if (!decc_efs_case_preserve) {
7738               *cp2 = _tolower(*cp1);  /* else lowercase for match */
7739             }
7740             else {
7741               *cp2 = *cp1;  /* else preserve case for match */
7742             }
7743          }
7744          if (*cp2 == '/') segdirs++;
7745       }
7746       if (cp1 != ellipsis - 1) {
7747           PerlMem_free(tpl);
7748           PerlMem_free(unixified);
7749           PerlMem_free(unixwild);
7750           PerlMem_free(lcres);
7751           return 0; /* Path too long */
7752       }
7753       /* Back up at least as many dirs as in template before matching */
7754       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7755         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7756       for (match = 0; cp1 > lcres;) {
7757         resdsc.dsc$a_pointer = cp1;
7758         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7759           match++;
7760           if (match == 1) lcfront = cp1;
7761         }
7762         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7763       }
7764       if (!match) {
7765         PerlMem_free(tpl);
7766         PerlMem_free(unixified);
7767         PerlMem_free(unixwild);
7768         PerlMem_free(lcres);
7769         return 0;  /* Can't find prefix ??? */
7770       }
7771       if (match > 1 && opts & 1) {
7772         /* This ... wildcard could cover more than one set of dirs (i.e.
7773          * a set of similar dir names is repeated).  If the template
7774          * contains more than 1 ..., upstream elements could resolve the
7775          * ambiguity, but it's not worth a full backtracking setup here.
7776          * As a quick heuristic, clip off the current default directory
7777          * if it's present to find the trimmed spec, else use the
7778          * shortest string that this ... could cover.
7779          */
7780         char def[NAM$C_MAXRSS+1], *st;
7781
7782         if (getcwd(def, sizeof def,0) == NULL) {
7783             Safefree(unixified);
7784             Safefree(unixwild);
7785             Safefree(lcres);
7786             Safefree(tpl);
7787             return 0;
7788         }
7789         if (!decc_efs_case_preserve) {
7790           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7791             if (_tolower(*cp1) != _tolower(*cp2)) break;
7792         }
7793         segdirs = dirs - totells;  /* Min # of dirs we must have left */
7794         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7795         if (*cp1 == '\0' && *cp2 == '/') {
7796           memmove(fspec,cp2+1,end - cp2);
7797           PerlMem_free(tpl);
7798           PerlMem_free(unixified);
7799           PerlMem_free(unixwild);
7800           PerlMem_free(lcres);
7801           return 1;
7802         }
7803         /* Nope -- stick with lcfront from above and keep going. */
7804       }
7805     }
7806     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7807     PerlMem_free(tpl);
7808     PerlMem_free(unixified);
7809     PerlMem_free(unixwild);
7810     PerlMem_free(lcres);
7811     return 1;
7812     ellipsis = nextell;
7813   }
7814
7815 }  /* end of trim_unixpath() */
7816 /*}}}*/
7817
7818
7819 /*
7820  *  VMS readdir() routines.
7821  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7822  *
7823  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
7824  *  Minor modifications to original routines.
7825  */
7826
7827 /* readdir may have been redefined by reentr.h, so make sure we get
7828  * the local version for what we do here.
7829  */
7830 #ifdef readdir
7831 # undef readdir
7832 #endif
7833 #if !defined(PERL_IMPLICIT_CONTEXT)
7834 # define readdir Perl_readdir
7835 #else
7836 # define readdir(a) Perl_readdir(aTHX_ a)
7837 #endif
7838
7839     /* Number of elements in vms_versions array */
7840 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
7841
7842 /*
7843  *  Open a directory, return a handle for later use.
7844  */
7845 /*{{{ DIR *opendir(char*name) */
7846 DIR *
7847 Perl_opendir(pTHX_ const char *name)
7848 {
7849     DIR *dd;
7850     char *dir;
7851     Stat_t sb;
7852     int unix_flag;
7853
7854     unix_flag = 0;
7855     if (decc_efs_charset) {
7856         unix_flag = is_unix_filespec(name);
7857     }
7858
7859     Newx(dir, VMS_MAXRSS, char);
7860     if (do_tovmspath(name,dir,0) == NULL) {
7861       Safefree(dir);
7862       return NULL;
7863     }
7864     /* Check access before stat; otherwise stat does not
7865      * accurately report whether it's a directory.
7866      */
7867     if (!cando_by_name(S_IRUSR,0,dir)) {
7868       /* cando_by_name has already set errno */
7869       Safefree(dir);
7870       return NULL;
7871     }
7872     if (flex_stat(dir,&sb) == -1) return NULL;
7873     if (!S_ISDIR(sb.st_mode)) {
7874       Safefree(dir);
7875       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
7876       return NULL;
7877     }
7878     /* Get memory for the handle, and the pattern. */
7879     Newx(dd,1,DIR);
7880     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7881
7882     /* Fill in the fields; mainly playing with the descriptor. */
7883     sprintf(dd->pattern, "%s*.*",dir);
7884     Safefree(dir);
7885     dd->context = 0;
7886     dd->count = 0;
7887     dd->flags = 0;
7888     if (unix_flag)
7889         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
7890     dd->pat.dsc$a_pointer = dd->pattern;
7891     dd->pat.dsc$w_length = strlen(dd->pattern);
7892     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7893     dd->pat.dsc$b_class = DSC$K_CLASS_S;
7894 #if defined(USE_ITHREADS)
7895     Newx(dd->mutex,1,perl_mutex);
7896     MUTEX_INIT( (perl_mutex *) dd->mutex );
7897 #else
7898     dd->mutex = NULL;
7899 #endif
7900
7901     return dd;
7902 }  /* end of opendir() */
7903 /*}}}*/
7904
7905 /*
7906  *  Set the flag to indicate we want versions or not.
7907  */
7908 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7909 void
7910 vmsreaddirversions(DIR *dd, int flag)
7911 {
7912     if (flag)
7913         dd->flags |= PERL_VMSDIR_M_VERSIONS;
7914     else
7915         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
7916 }
7917 /*}}}*/
7918
7919 /*
7920  *  Free up an opened directory.
7921  */
7922 /*{{{ void closedir(DIR *dd)*/
7923 void
7924 Perl_closedir(DIR *dd)
7925 {
7926     int sts;
7927
7928     sts = lib$find_file_end(&dd->context);
7929     Safefree(dd->pattern);
7930 #if defined(USE_ITHREADS)
7931     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7932     Safefree(dd->mutex);
7933 #endif
7934     Safefree(dd);
7935 }
7936 /*}}}*/
7937
7938 /*
7939  *  Collect all the version numbers for the current file.
7940  */
7941 static void
7942 collectversions(pTHX_ DIR *dd)
7943 {
7944     struct dsc$descriptor_s     pat;
7945     struct dsc$descriptor_s     res;
7946     struct dirent *e;
7947     char *p, *text, *buff;
7948     int i;
7949     unsigned long context, tmpsts;
7950
7951     /* Convenient shorthand. */
7952     e = &dd->entry;
7953
7954     /* Add the version wildcard, ignoring the "*.*" put on before */
7955     i = strlen(dd->pattern);
7956     Newx(text,i + e->d_namlen + 3,char);
7957     strcpy(text, dd->pattern);
7958     sprintf(&text[i - 3], "%s;*", e->d_name);
7959
7960     /* Set up the pattern descriptor. */
7961     pat.dsc$a_pointer = text;
7962     pat.dsc$w_length = i + e->d_namlen - 1;
7963     pat.dsc$b_dtype = DSC$K_DTYPE_T;
7964     pat.dsc$b_class = DSC$K_CLASS_S;
7965
7966     /* Set up result descriptor. */
7967     Newx(buff, VMS_MAXRSS, char);
7968     res.dsc$a_pointer = buff;
7969     res.dsc$w_length = VMS_MAXRSS - 1;
7970     res.dsc$b_dtype = DSC$K_DTYPE_T;
7971     res.dsc$b_class = DSC$K_CLASS_S;
7972
7973     /* Read files, collecting versions. */
7974     for (context = 0, e->vms_verscount = 0;
7975          e->vms_verscount < VERSIZE(e);
7976          e->vms_verscount++) {
7977         unsigned long rsts;
7978         unsigned long flags = 0;
7979
7980 #ifdef VMS_LONGNAME_SUPPORT
7981         flags = LIB$M_FIL_LONG_NAMES
7982 #endif
7983         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
7984         if (tmpsts == RMS$_NMF || context == 0) break;
7985         _ckvmssts(tmpsts);
7986         buff[VMS_MAXRSS - 1] = '\0';
7987         if ((p = strchr(buff, ';')))
7988             e->vms_versions[e->vms_verscount] = atoi(p + 1);
7989         else
7990             e->vms_versions[e->vms_verscount] = -1;
7991     }
7992
7993     _ckvmssts(lib$find_file_end(&context));
7994     Safefree(text);
7995     Safefree(buff);
7996
7997 }  /* end of collectversions() */
7998
7999 /*
8000  *  Read the next entry from the directory.
8001  */
8002 /*{{{ struct dirent *readdir(DIR *dd)*/
8003 struct dirent *
8004 Perl_readdir(pTHX_ DIR *dd)
8005 {
8006     struct dsc$descriptor_s     res;
8007     char *p, *buff;
8008     unsigned long int tmpsts;
8009     unsigned long rsts;
8010     unsigned long flags = 0;
8011     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8012     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8013
8014     /* Set up result descriptor, and get next file. */
8015     Newx(buff, VMS_MAXRSS, char);
8016     res.dsc$a_pointer = buff;
8017     res.dsc$w_length = VMS_MAXRSS - 1;
8018     res.dsc$b_dtype = DSC$K_DTYPE_T;
8019     res.dsc$b_class = DSC$K_CLASS_S;
8020
8021 #ifdef VMS_LONGNAME_SUPPORT
8022     flags = LIB$M_FIL_LONG_NAMES
8023 #endif
8024
8025     tmpsts = lib$find_file
8026         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8027     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8028     if (!(tmpsts & 1)) {
8029       set_vaxc_errno(tmpsts);
8030       switch (tmpsts) {
8031         case RMS$_PRV:
8032           set_errno(EACCES); break;
8033         case RMS$_DEV:
8034           set_errno(ENODEV); break;
8035         case RMS$_DIR:
8036           set_errno(ENOTDIR); break;
8037         case RMS$_FNF: case RMS$_DNF:
8038           set_errno(ENOENT); break;
8039         default:
8040           set_errno(EVMSERR);
8041       }
8042       Safefree(buff);
8043       return NULL;
8044     }
8045     dd->count++;
8046     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8047     if (!decc_efs_case_preserve) {
8048       buff[VMS_MAXRSS - 1] = '\0';
8049       for (p = buff; *p; p++) *p = _tolower(*p);
8050     }
8051     else {
8052       /* we don't want to force to lowercase, just null terminate */
8053       buff[res.dsc$w_length] = '\0';
8054     }
8055     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8056     *p = '\0';
8057
8058     /* Skip any directory component and just copy the name. */
8059     sts = vms_split_path
8060        (aTHX_ buff,
8061         &v_spec,
8062         &v_len,
8063         &r_spec,
8064         &r_len,
8065         &d_spec,
8066         &d_len,
8067         &n_spec,
8068         &n_len,
8069         &e_spec,
8070         &e_len,
8071         &vs_spec,
8072         &vs_len);
8073
8074     /* Drop NULL extensions on UNIX file specification */
8075     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8076         (e_len == 1) && decc_readdir_dropdotnotype)) {
8077         e_len = 0;
8078         e_spec[0] = '\0';
8079     }
8080
8081     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8082     dd->entry.d_name[n_len + e_len] = '\0';
8083     dd->entry.d_namlen = strlen(dd->entry.d_name);
8084
8085     /* Convert the filename to UNIX format if needed */
8086     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8087
8088         /* Translate the encoded characters. */
8089         /* Fixme: unicode handling could result in embedded 0 characters */
8090         if (strchr(dd->entry.d_name, '^') != NULL) {
8091             char new_name[256];
8092             char * q;
8093             int cnt;
8094             p = dd->entry.d_name;
8095             q = new_name;
8096             while (*p != 0) {
8097                 int x, y;
8098                 x = copy_expand_vms_filename_escape(q, p, &y);
8099                 p += x;
8100                 q += y;
8101                 /* fix-me */
8102                 /* if y > 1, then this is a wide file specification */
8103                 /* Wide file specifications need to be passed in Perl */
8104                 /* counted strings apparently with a unicode flag */
8105             }
8106             *q = 0;
8107             strcpy(dd->entry.d_name, new_name);
8108         }
8109     }
8110
8111     dd->entry.vms_verscount = 0;
8112     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8113     Safefree(buff);
8114     return &dd->entry;
8115
8116 }  /* end of readdir() */
8117 /*}}}*/
8118
8119 /*
8120  *  Read the next entry from the directory -- thread-safe version.
8121  */
8122 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8123 int
8124 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8125 {
8126     int retval;
8127
8128     MUTEX_LOCK( (perl_mutex *) dd->mutex );
8129
8130     entry = readdir(dd);
8131     *result = entry;
8132     retval = ( *result == NULL ? errno : 0 );
8133
8134     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8135
8136     return retval;
8137
8138 }  /* end of readdir_r() */
8139 /*}}}*/
8140
8141 /*
8142  *  Return something that can be used in a seekdir later.
8143  */
8144 /*{{{ long telldir(DIR *dd)*/
8145 long
8146 Perl_telldir(DIR *dd)
8147 {
8148     return dd->count;
8149 }
8150 /*}}}*/
8151
8152 /*
8153  *  Return to a spot where we used to be.  Brute force.
8154  */
8155 /*{{{ void seekdir(DIR *dd,long count)*/
8156 void
8157 Perl_seekdir(pTHX_ DIR *dd, long count)
8158 {
8159     int old_flags;
8160
8161     /* If we haven't done anything yet... */
8162     if (dd->count == 0)
8163         return;
8164
8165     /* Remember some state, and clear it. */
8166     old_flags = dd->flags;
8167     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8168     _ckvmssts(lib$find_file_end(&dd->context));
8169     dd->context = 0;
8170
8171     /* The increment is in readdir(). */
8172     for (dd->count = 0; dd->count < count; )
8173         readdir(dd);
8174
8175     dd->flags = old_flags;
8176
8177 }  /* end of seekdir() */
8178 /*}}}*/
8179
8180 /* VMS subprocess management
8181  *
8182  * my_vfork() - just a vfork(), after setting a flag to record that
8183  * the current script is trying a Unix-style fork/exec.
8184  *
8185  * vms_do_aexec() and vms_do_exec() are called in response to the
8186  * perl 'exec' function.  If this follows a vfork call, then they
8187  * call out the regular perl routines in doio.c which do an
8188  * execvp (for those who really want to try this under VMS).
8189  * Otherwise, they do exactly what the perl docs say exec should
8190  * do - terminate the current script and invoke a new command
8191  * (See below for notes on command syntax.)
8192  *
8193  * do_aspawn() and do_spawn() implement the VMS side of the perl
8194  * 'system' function.
8195  *
8196  * Note on command arguments to perl 'exec' and 'system': When handled
8197  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8198  * are concatenated to form a DCL command string.  If the first arg
8199  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8200  * the command string is handed off to DCL directly.  Otherwise,
8201  * the first token of the command is taken as the filespec of an image
8202  * to run.  The filespec is expanded using a default type of '.EXE' and
8203  * the process defaults for device, directory, etc., and if found, the resultant
8204  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8205  * the command string as parameters.  This is perhaps a bit complicated,
8206  * but I hope it will form a happy medium between what VMS folks expect
8207  * from lib$spawn and what Unix folks expect from exec.
8208  */
8209
8210 static int vfork_called;
8211
8212 /*{{{int my_vfork()*/
8213 int
8214 my_vfork()
8215 {
8216   vfork_called++;
8217   return vfork();
8218 }
8219 /*}}}*/
8220
8221
8222 static void
8223 vms_execfree(struct dsc$descriptor_s *vmscmd)
8224 {
8225   if (vmscmd) {
8226       if (vmscmd->dsc$a_pointer) {
8227           PerlMem_free(vmscmd->dsc$a_pointer);
8228       }
8229       PerlMem_free(vmscmd);
8230   }
8231 }
8232
8233 static char *
8234 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8235 {
8236   char *junk, *tmps = Nullch;
8237   register size_t cmdlen = 0;
8238   size_t rlen;
8239   register SV **idx;
8240   STRLEN n_a;
8241
8242   idx = mark;
8243   if (really) {
8244     tmps = SvPV(really,rlen);
8245     if (*tmps) {
8246       cmdlen += rlen + 1;
8247       idx++;
8248     }
8249   }
8250
8251   for (idx++; idx <= sp; idx++) {
8252     if (*idx) {
8253       junk = SvPVx(*idx,rlen);
8254       cmdlen += rlen ? rlen + 1 : 0;
8255     }
8256   }
8257   Newx(PL_Cmd, cmdlen+1, char);
8258
8259   if (tmps && *tmps) {
8260     strcpy(PL_Cmd,tmps);
8261     mark++;
8262   }
8263   else *PL_Cmd = '\0';
8264   while (++mark <= sp) {
8265     if (*mark) {
8266       char *s = SvPVx(*mark,n_a);
8267       if (!*s) continue;
8268       if (*PL_Cmd) strcat(PL_Cmd," ");
8269       strcat(PL_Cmd,s);
8270     }
8271   }
8272   return PL_Cmd;
8273
8274 }  /* end of setup_argstr() */
8275
8276
8277 static unsigned long int
8278 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8279                    struct dsc$descriptor_s **pvmscmd)
8280 {
8281   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8282   char image_name[NAM$C_MAXRSS+1];
8283   char image_argv[NAM$C_MAXRSS+1];
8284   $DESCRIPTOR(defdsc,".EXE");
8285   $DESCRIPTOR(defdsc2,".");
8286   $DESCRIPTOR(resdsc,resspec);
8287   struct dsc$descriptor_s *vmscmd;
8288   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8289   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8290   register char *s, *rest, *cp, *wordbreak;
8291   char * cmd;
8292   int cmdlen;
8293   register int isdcl;
8294
8295   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8296   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8297
8298   /* Make a copy for modification */
8299   cmdlen = strlen(incmd);
8300   cmd = PerlMem_malloc(cmdlen+1);
8301   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8302   strncpy(cmd, incmd, cmdlen);
8303   cmd[cmdlen] = 0;
8304   image_name[0] = 0;
8305   image_argv[0] = 0;
8306
8307   vmscmd->dsc$a_pointer = NULL;
8308   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
8309   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
8310   vmscmd->dsc$w_length = 0;
8311   if (pvmscmd) *pvmscmd = vmscmd;
8312
8313   if (suggest_quote) *suggest_quote = 0;
8314
8315   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8316     PerlMem_free(cmd);
8317     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
8318   }
8319
8320   s = cmd;
8321
8322   while (*s && isspace(*s)) s++;
8323
8324   if (*s == '@' || *s == '$') {
8325     vmsspec[0] = *s;  rest = s + 1;
8326     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8327   }
8328   else { cp = vmsspec; rest = s; }
8329   if (*rest == '.' || *rest == '/') {
8330     char *cp2;
8331     for (cp2 = resspec;
8332          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8333          rest++, cp2++) *cp2 = *rest;
8334     *cp2 = '\0';
8335     if (do_tovmsspec(resspec,cp,0)) {
8336       s = vmsspec;
8337       if (*rest) {
8338         for (cp2 = vmsspec + strlen(vmsspec);
8339              *rest && cp2 - vmsspec < sizeof vmsspec;
8340              rest++, cp2++) *cp2 = *rest;
8341         *cp2 = '\0';
8342       }
8343     }
8344   }
8345   /* Intuit whether verb (first word of cmd) is a DCL command:
8346    *   - if first nonspace char is '@', it's a DCL indirection
8347    * otherwise
8348    *   - if verb contains a filespec separator, it's not a DCL command
8349    *   - if it doesn't, caller tells us whether to default to a DCL
8350    *     command, or to a local image unless told it's DCL (by leading '$')
8351    */
8352   if (*s == '@') {
8353       isdcl = 1;
8354       if (suggest_quote) *suggest_quote = 1;
8355   } else {
8356     register char *filespec = strpbrk(s,":<[.;");
8357     rest = wordbreak = strpbrk(s," \"\t/");
8358     if (!wordbreak) wordbreak = s + strlen(s);
8359     if (*s == '$') check_img = 0;
8360     if (filespec && (filespec < wordbreak)) isdcl = 0;
8361     else isdcl = !check_img;
8362   }
8363
8364   if (!isdcl) {
8365     int rsts;
8366     imgdsc.dsc$a_pointer = s;
8367     imgdsc.dsc$w_length = wordbreak - s;
8368     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8369     if (!(retsts&1)) {
8370         _ckvmssts(lib$find_file_end(&cxt));
8371         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8372       if (!(retsts & 1) && *s == '$') {
8373         _ckvmssts(lib$find_file_end(&cxt));
8374         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8375         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8376         if (!(retsts&1)) {
8377           _ckvmssts(lib$find_file_end(&cxt));
8378           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8379         }
8380       }
8381     }
8382     _ckvmssts(lib$find_file_end(&cxt));
8383
8384     if (retsts & 1) {
8385       FILE *fp;
8386       s = resspec;
8387       while (*s && !isspace(*s)) s++;
8388       *s = '\0';
8389
8390       /* check that it's really not DCL with no file extension */
8391       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8392       if (fp) {
8393         char b[256] = {0,0,0,0};
8394         read(fileno(fp), b, 256);
8395         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
8396         if (isdcl) {
8397           int shebang_len;
8398
8399           /* Check for script */
8400           shebang_len = 0;
8401           if ((b[0] == '#') && (b[1] == '!'))
8402              shebang_len = 2;
8403 #ifdef ALTERNATE_SHEBANG
8404           else {
8405             shebang_len = strlen(ALTERNATE_SHEBANG);
8406             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
8407               char * perlstr;
8408                 perlstr = strstr("perl",b);
8409                 if (perlstr == NULL)
8410                   shebang_len = 0;
8411             }
8412             else
8413               shebang_len = 0;
8414           }
8415 #endif
8416
8417           if (shebang_len > 0) {
8418           int i;
8419           int j;
8420           char tmpspec[NAM$C_MAXRSS + 1];
8421
8422             i = shebang_len;
8423              /* Image is following after white space */
8424             /*--------------------------------------*/
8425             while (isprint(b[i]) && isspace(b[i]))
8426                 i++;
8427
8428             j = 0;
8429             while (isprint(b[i]) && !isspace(b[i])) {
8430                 tmpspec[j++] = b[i++];
8431                 if (j >= NAM$C_MAXRSS)
8432                    break;
8433             }
8434             tmpspec[j] = '\0';
8435
8436              /* There may be some default parameters to the image */
8437             /*---------------------------------------------------*/
8438             j = 0;
8439             while (isprint(b[i])) {
8440                 image_argv[j++] = b[i++];
8441                 if (j >= NAM$C_MAXRSS)
8442                    break;
8443             }
8444             while ((j > 0) && !isprint(image_argv[j-1]))
8445                 j--;
8446             image_argv[j] = 0;
8447
8448             /* It will need to be converted to VMS format and validated */
8449             if (tmpspec[0] != '\0') {
8450               char * iname;
8451
8452                /* Try to find the exact program requested to be run */
8453               /*---------------------------------------------------*/
8454               iname = do_rmsexpand
8455                   (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8456               if (iname != NULL) {
8457                 if (cando_by_name(S_IXUSR,0,image_name)) {
8458                   /* MCR prefix needed */
8459                   isdcl = 0;
8460                 }
8461                 else {
8462                    /* Try again with a null type */
8463                   /*----------------------------*/
8464                   iname = do_rmsexpand
8465                     (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8466                   if (iname != NULL) {
8467                     if (cando_by_name(S_IXUSR,0,image_name)) {
8468                       /* MCR prefix needed */
8469                       isdcl = 0;
8470                     }
8471                   }
8472                 }
8473
8474                  /* Did we find the image to run the script? */
8475                 /*------------------------------------------*/
8476                 if (isdcl) {
8477                   char *tchr;
8478
8479                    /* Assume DCL or foreign command exists */
8480                   /*--------------------------------------*/
8481                   tchr = strrchr(tmpspec, '/');
8482                   if (tchr != NULL) {
8483                     tchr++;
8484                   }
8485                   else {
8486                     tchr = tmpspec;
8487                   }
8488                   strcpy(image_name, tchr);
8489                 }
8490               }
8491             }
8492           }
8493         }
8494         fclose(fp);
8495       }
8496       if (check_img && isdcl) return RMS$_FNF;
8497
8498       if (cando_by_name(S_IXUSR,0,resspec)) {
8499         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
8500         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
8501         if (!isdcl) {
8502             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8503             if (image_name[0] != 0) {
8504                 strcat(vmscmd->dsc$a_pointer, image_name);
8505                 strcat(vmscmd->dsc$a_pointer, " ");
8506             }
8507         } else if (image_name[0] != 0) {
8508             strcpy(vmscmd->dsc$a_pointer, image_name);
8509             strcat(vmscmd->dsc$a_pointer, " ");
8510         } else {
8511             strcpy(vmscmd->dsc$a_pointer,"@");
8512         }
8513         if (suggest_quote) *suggest_quote = 1;
8514
8515         /* If there is an image name, use original command */
8516         if (image_name[0] == 0)
8517             strcat(vmscmd->dsc$a_pointer,resspec);
8518         else {
8519             rest = cmd;
8520             while (*rest && isspace(*rest)) rest++;
8521         }
8522
8523         if (image_argv[0] != 0) {
8524           strcat(vmscmd->dsc$a_pointer,image_argv);
8525           strcat(vmscmd->dsc$a_pointer, " ");
8526         }
8527         if (rest) {
8528            int rest_len;
8529            int vmscmd_len;
8530
8531            rest_len = strlen(rest);
8532            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8533            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8534               strcat(vmscmd->dsc$a_pointer,rest);
8535            else
8536              retsts = CLI$_BUFOVF;
8537         }
8538         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8539         PerlMem_free(cmd);
8540         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8541       }
8542       else
8543         retsts = RMS$_PRV;
8544     }
8545   }
8546   /* It's either a DCL command or we couldn't find a suitable image */
8547   vmscmd->dsc$w_length = strlen(cmd);
8548
8549   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
8550   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
8551   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
8552
8553   PerlMem_free(cmd);
8554
8555   /* check if it's a symbol (for quoting purposes) */
8556   if (suggest_quote && !*suggest_quote) {
8557     int iss;
8558     char equiv[LNM$C_NAMLENGTH];
8559     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8560     eqvdsc.dsc$a_pointer = equiv;
8561
8562     iss = lib$get_symbol(vmscmd,&eqvdsc);
8563     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8564   }
8565   if (!(retsts & 1)) {
8566     /* just hand off status values likely to be due to user error */
8567     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8568         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8569        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8570     else { _ckvmssts(retsts); }
8571   }
8572
8573   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8574
8575 }  /* end of setup_cmddsc() */
8576
8577
8578 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8579 bool
8580 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8581 {
8582 bool exec_sts;
8583 char * cmd;
8584
8585   if (sp > mark) {
8586     if (vfork_called) {           /* this follows a vfork - act Unixish */
8587       vfork_called--;
8588       if (vfork_called < 0) {
8589         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8590         vfork_called = 0;
8591       }
8592       else return do_aexec(really,mark,sp);
8593     }
8594                                            /* no vfork - act VMSish */
8595     cmd = setup_argstr(aTHX_ really,mark,sp);
8596     exec_sts = vms_do_exec(cmd);
8597     Safefree(cmd);  /* Clean up from setup_argstr() */
8598     return exec_sts;
8599   }
8600
8601   return FALSE;
8602 }  /* end of vms_do_aexec() */
8603 /*}}}*/
8604
8605 /* {{{bool vms_do_exec(char *cmd) */
8606 bool
8607 Perl_vms_do_exec(pTHX_ const char *cmd)
8608 {
8609   struct dsc$descriptor_s *vmscmd;
8610
8611   if (vfork_called) {             /* this follows a vfork - act Unixish */
8612     vfork_called--;
8613     if (vfork_called < 0) {
8614       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8615       vfork_called = 0;
8616     }
8617     else return do_exec(cmd);
8618   }
8619
8620   {                               /* no vfork - act VMSish */
8621     unsigned long int retsts;
8622
8623     TAINT_ENV();
8624     TAINT_PROPER("exec");
8625     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8626       retsts = lib$do_command(vmscmd);
8627
8628     switch (retsts) {
8629       case RMS$_FNF: case RMS$_DNF:
8630         set_errno(ENOENT); break;
8631       case RMS$_DIR:
8632         set_errno(ENOTDIR); break;
8633       case RMS$_DEV:
8634         set_errno(ENODEV); break;
8635       case RMS$_PRV:
8636         set_errno(EACCES); break;
8637       case RMS$_SYN:
8638         set_errno(EINVAL); break;
8639       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8640         set_errno(E2BIG); break;
8641       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8642         _ckvmssts(retsts); /* fall through */
8643       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8644         set_errno(EVMSERR);
8645     }
8646     set_vaxc_errno(retsts);
8647     if (ckWARN(WARN_EXEC)) {
8648       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8649              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8650     }
8651     vms_execfree(vmscmd);
8652   }
8653
8654   return FALSE;
8655
8656 }  /* end of vms_do_exec() */
8657 /*}}}*/
8658
8659 unsigned long int Perl_do_spawn(pTHX_ const char *);
8660
8661 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8662 unsigned long int
8663 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8664 {
8665 unsigned long int sts;
8666 char * cmd;
8667
8668   if (sp > mark) {
8669     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
8670     sts = do_spawn(cmd);
8671     /* pp_sys will clean up cmd */
8672     return sts;
8673   }
8674   return SS$_ABORT;
8675 }  /* end of do_aspawn() */
8676 /*}}}*/
8677
8678 /* {{{unsigned long int do_spawn(char *cmd) */
8679 unsigned long int
8680 Perl_do_spawn(pTHX_ const char *cmd)
8681 {
8682   unsigned long int sts, substs;
8683
8684   /* The caller of this routine expects to Safefree(PL_Cmd) */
8685   Newx(PL_Cmd,10,char);
8686
8687   TAINT_ENV();
8688   TAINT_PROPER("spawn");
8689   if (!cmd || !*cmd) {
8690     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8691     if (!(sts & 1)) {
8692       switch (sts) {
8693         case RMS$_FNF:  case RMS$_DNF:
8694           set_errno(ENOENT); break;
8695         case RMS$_DIR:
8696           set_errno(ENOTDIR); break;
8697         case RMS$_DEV:
8698           set_errno(ENODEV); break;
8699         case RMS$_PRV:
8700           set_errno(EACCES); break;
8701         case RMS$_SYN:
8702           set_errno(EINVAL); break;
8703         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8704           set_errno(E2BIG); break;
8705         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8706           _ckvmssts(sts); /* fall through */
8707         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8708           set_errno(EVMSERR);
8709       }
8710       set_vaxc_errno(sts);
8711       if (ckWARN(WARN_EXEC)) {
8712         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8713                     Strerror(errno));
8714       }
8715     }
8716     sts = substs;
8717   }
8718   else {
8719     PerlIO * fp;
8720     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8721     if (fp != NULL)
8722       my_pclose(fp);
8723   }
8724   return sts;
8725 }  /* end of do_spawn() */
8726 /*}}}*/
8727
8728
8729 static unsigned int *sockflags, sockflagsize;
8730
8731 /*
8732  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8733  * routines found in some versions of the CRTL can't deal with sockets.
8734  * We don't shim the other file open routines since a socket isn't
8735  * likely to be opened by a name.
8736  */
8737 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8738 FILE *my_fdopen(int fd, const char *mode)
8739 {
8740   FILE *fp = fdopen(fd, mode);
8741
8742   if (fp) {
8743     unsigned int fdoff = fd / sizeof(unsigned int);
8744     Stat_t sbuf; /* native stat; we don't need flex_stat */
8745     if (!sockflagsize || fdoff > sockflagsize) {
8746       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
8747       else           Newx  (sockflags,fdoff+2,unsigned int);
8748       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8749       sockflagsize = fdoff + 2;
8750     }
8751     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8752       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8753   }
8754   return fp;
8755
8756 }
8757 /*}}}*/
8758
8759
8760 /*
8761  * Clear the corresponding bit when the (possibly) socket stream is closed.
8762  * There still a small hole: we miss an implicit close which might occur
8763  * via freopen().  >> Todo
8764  */
8765 /*{{{ int my_fclose(FILE *fp)*/
8766 int my_fclose(FILE *fp) {
8767   if (fp) {
8768     unsigned int fd = fileno(fp);
8769     unsigned int fdoff = fd / sizeof(unsigned int);
8770
8771     if (sockflagsize && fdoff <= sockflagsize)
8772       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8773   }
8774   return fclose(fp);
8775 }
8776 /*}}}*/
8777
8778
8779 /*
8780  * A simple fwrite replacement which outputs itmsz*nitm chars without
8781  * introducing record boundaries every itmsz chars.
8782  * We are using fputs, which depends on a terminating null.  We may
8783  * well be writing binary data, so we need to accommodate not only
8784  * data with nulls sprinkled in the middle but also data with no null
8785  * byte at the end.
8786  */
8787 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8788 int
8789 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8790 {
8791   register char *cp, *end, *cpd, *data;
8792   register unsigned int fd = fileno(dest);
8793   register unsigned int fdoff = fd / sizeof(unsigned int);
8794   int retval;
8795   int bufsize = itmsz * nitm + 1;
8796
8797   if (fdoff < sockflagsize &&
8798       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8799     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8800     return nitm;
8801   }
8802
8803   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8804   memcpy( data, src, itmsz*nitm );
8805   data[itmsz*nitm] = '\0';
8806
8807   end = data + itmsz * nitm;
8808   retval = (int) nitm; /* on success return # items written */
8809
8810   cpd = data;
8811   while (cpd <= end) {
8812     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8813     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8814     if (cp < end)
8815       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8816     cpd = cp + 1;
8817   }
8818
8819   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8820   return retval;
8821
8822 }  /* end of my_fwrite() */
8823 /*}}}*/
8824
8825 /*{{{ int my_flush(FILE *fp)*/
8826 int
8827 Perl_my_flush(pTHX_ FILE *fp)
8828 {
8829     int res;
8830     if ((res = fflush(fp)) == 0 && fp) {
8831 #ifdef VMS_DO_SOCKETS
8832         Stat_t s;
8833         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8834 #endif
8835             res = fsync(fileno(fp));
8836     }
8837 /*
8838  * If the flush succeeded but set end-of-file, we need to clear
8839  * the error because our caller may check ferror().  BTW, this
8840  * probably means we just flushed an empty file.
8841  */
8842     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8843
8844     return res;
8845 }
8846 /*}}}*/
8847
8848 /*
8849  * Here are replacements for the following Unix routines in the VMS environment:
8850  *      getpwuid    Get information for a particular UIC or UID
8851  *      getpwnam    Get information for a named user
8852  *      getpwent    Get information for each user in the rights database
8853  *      setpwent    Reset search to the start of the rights database
8854  *      endpwent    Finish searching for users in the rights database
8855  *
8856  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8857  * (defined in pwd.h), which contains the following fields:-
8858  *      struct passwd {
8859  *              char        *pw_name;    Username (in lower case)
8860  *              char        *pw_passwd;  Hashed password
8861  *              unsigned int pw_uid;     UIC
8862  *              unsigned int pw_gid;     UIC group  number
8863  *              char        *pw_unixdir; Default device/directory (VMS-style)
8864  *              char        *pw_gecos;   Owner name
8865  *              char        *pw_dir;     Default device/directory (Unix-style)
8866  *              char        *pw_shell;   Default CLI name (eg. DCL)
8867  *      };
8868  * If the specified user does not exist, getpwuid and getpwnam return NULL.
8869  *
8870  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8871  * not the UIC member number (eg. what's returned by getuid()),
8872  * getpwuid() can accept either as input (if uid is specified, the caller's
8873  * UIC group is used), though it won't recognise gid=0.
8874  *
8875  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8876  * information about other users in your group or in other groups, respectively.
8877  * If the required privilege is not available, then these routines fill only
8878  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8879  * string).
8880  *
8881  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8882  */
8883
8884 /* sizes of various UAF record fields */
8885 #define UAI$S_USERNAME 12
8886 #define UAI$S_IDENT    31
8887 #define UAI$S_OWNER    31
8888 #define UAI$S_DEFDEV   31
8889 #define UAI$S_DEFDIR   63
8890 #define UAI$S_DEFCLI   31
8891 #define UAI$S_PWD       8
8892
8893 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
8894                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8895                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
8896
8897 static char __empty[]= "";
8898 static struct passwd __passwd_empty=
8899     {(char *) __empty, (char *) __empty, 0, 0,
8900      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8901 static int contxt= 0;
8902 static struct passwd __pwdcache;
8903 static char __pw_namecache[UAI$S_IDENT+1];
8904
8905 /*
8906  * This routine does most of the work extracting the user information.
8907  */
8908 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8909 {
8910     static struct {
8911         unsigned char length;
8912         char pw_gecos[UAI$S_OWNER+1];
8913     } owner;
8914     static union uicdef uic;
8915     static struct {
8916         unsigned char length;
8917         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8918     } defdev;
8919     static struct {
8920         unsigned char length;
8921         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8922     } defdir;
8923     static struct {
8924         unsigned char length;
8925         char pw_shell[UAI$S_DEFCLI+1];
8926     } defcli;
8927     static char pw_passwd[UAI$S_PWD+1];
8928
8929     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8930     struct dsc$descriptor_s name_desc;
8931     unsigned long int sts;
8932
8933     static struct itmlst_3 itmlst[]= {
8934         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
8935         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
8936         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
8937         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
8938         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
8939         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
8940         {0,                0,           NULL,    NULL}};
8941
8942     name_desc.dsc$w_length=  strlen(name);
8943     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8944     name_desc.dsc$b_class=   DSC$K_CLASS_S;
8945     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8946
8947 /*  Note that sys$getuai returns many fields as counted strings. */
8948     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8949     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8950       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8951     }
8952     else { _ckvmssts(sts); }
8953     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
8954
8955     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
8956     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8957     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8958     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8959     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8960     owner.pw_gecos[lowner]=            '\0';
8961     defdev.pw_dir[ldefdev+ldefdir]= '\0';
8962     defcli.pw_shell[ldefcli]=          '\0';
8963     if (valid_uic(uic)) {
8964         pwd->pw_uid= uic.uic$l_uic;
8965         pwd->pw_gid= uic.uic$v_group;
8966     }
8967     else
8968       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8969     pwd->pw_passwd=  pw_passwd;
8970     pwd->pw_gecos=   owner.pw_gecos;
8971     pwd->pw_dir=     defdev.pw_dir;
8972     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8973     pwd->pw_shell=   defcli.pw_shell;
8974     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8975         int ldir;
8976         ldir= strlen(pwd->pw_unixdir) - 1;
8977         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8978     }
8979     else
8980         strcpy(pwd->pw_unixdir, pwd->pw_dir);
8981     if (!decc_efs_case_preserve)
8982         __mystrtolower(pwd->pw_unixdir);
8983     return 1;
8984 }
8985
8986 /*
8987  * Get information for a named user.
8988 */
8989 /*{{{struct passwd *getpwnam(char *name)*/
8990 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8991 {
8992     struct dsc$descriptor_s name_desc;
8993     union uicdef uic;
8994     unsigned long int status, sts;
8995
8996     __pwdcache = __passwd_empty;
8997     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8998       /* We still may be able to determine pw_uid and pw_gid */
8999       name_desc.dsc$w_length=  strlen(name);
9000       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9001       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9002       name_desc.dsc$a_pointer= (char *) name;
9003       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9004         __pwdcache.pw_uid= uic.uic$l_uic;
9005         __pwdcache.pw_gid= uic.uic$v_group;
9006       }
9007       else {
9008         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9009           set_vaxc_errno(sts);
9010           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9011           return NULL;
9012         }
9013         else { _ckvmssts(sts); }
9014       }
9015     }
9016     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9017     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9018     __pwdcache.pw_name= __pw_namecache;
9019     return &__pwdcache;
9020 }  /* end of my_getpwnam() */
9021 /*}}}*/
9022
9023 /*
9024  * Get information for a particular UIC or UID.
9025  * Called by my_getpwent with uid=-1 to list all users.
9026 */
9027 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9028 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9029 {
9030     const $DESCRIPTOR(name_desc,__pw_namecache);
9031     unsigned short lname;
9032     union uicdef uic;
9033     unsigned long int status;
9034
9035     if (uid == (unsigned int) -1) {
9036       do {
9037         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9038         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9039           set_vaxc_errno(status);
9040           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9041           my_endpwent();
9042           return NULL;
9043         }
9044         else { _ckvmssts(status); }
9045       } while (!valid_uic (uic));
9046     }
9047     else {
9048       uic.uic$l_uic= uid;
9049       if (!uic.uic$v_group)
9050         uic.uic$v_group= PerlProc_getgid();
9051       if (valid_uic(uic))
9052         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9053       else status = SS$_IVIDENT;
9054       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9055           status == RMS$_PRV) {
9056         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9057         return NULL;
9058       }
9059       else { _ckvmssts(status); }
9060     }
9061     __pw_namecache[lname]= '\0';
9062     __mystrtolower(__pw_namecache);
9063
9064     __pwdcache = __passwd_empty;
9065     __pwdcache.pw_name = __pw_namecache;
9066
9067 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9068     The identifier's value is usually the UIC, but it doesn't have to be,
9069     so if we can, we let fillpasswd update this. */
9070     __pwdcache.pw_uid =  uic.uic$l_uic;
9071     __pwdcache.pw_gid =  uic.uic$v_group;
9072
9073     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9074     return &__pwdcache;
9075
9076 }  /* end of my_getpwuid() */
9077 /*}}}*/
9078
9079 /*
9080  * Get information for next user.
9081 */
9082 /*{{{struct passwd *my_getpwent()*/
9083 struct passwd *Perl_my_getpwent(pTHX)
9084 {
9085     return (my_getpwuid((unsigned int) -1));
9086 }
9087 /*}}}*/
9088
9089 /*
9090  * Finish searching rights database for users.
9091 */
9092 /*{{{void my_endpwent()*/
9093 void Perl_my_endpwent(pTHX)
9094 {
9095     if (contxt) {
9096       _ckvmssts(sys$finish_rdb(&contxt));
9097       contxt= 0;
9098     }
9099 }
9100 /*}}}*/
9101
9102 #ifdef HOMEGROWN_POSIX_SIGNALS
9103   /* Signal handling routines, pulled into the core from POSIX.xs.
9104    *
9105    * We need these for threads, so they've been rolled into the core,
9106    * rather than left in POSIX.xs.
9107    *
9108    * (DRS, Oct 23, 1997)
9109    */
9110
9111   /* sigset_t is atomic under VMS, so these routines are easy */
9112 /*{{{int my_sigemptyset(sigset_t *) */
9113 int my_sigemptyset(sigset_t *set) {
9114     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9115     *set = 0; return 0;
9116 }
9117 /*}}}*/
9118
9119
9120 /*{{{int my_sigfillset(sigset_t *)*/
9121 int my_sigfillset(sigset_t *set) {
9122     int i;
9123     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9124     for (i = 0; i < NSIG; i++) *set |= (1 << i);
9125     return 0;
9126 }
9127 /*}}}*/
9128
9129
9130 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9131 int my_sigaddset(sigset_t *set, int sig) {
9132     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9133     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9134     *set |= (1 << (sig - 1));
9135     return 0;
9136 }
9137 /*}}}*/
9138
9139
9140 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9141 int my_sigdelset(sigset_t *set, int sig) {
9142     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9143     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9144     *set &= ~(1 << (sig - 1));
9145     return 0;
9146 }
9147 /*}}}*/
9148
9149
9150 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9151 int my_sigismember(sigset_t *set, int sig) {
9152     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9153     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9154     return *set & (1 << (sig - 1));
9155 }
9156 /*}}}*/
9157
9158
9159 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9160 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9161     sigset_t tempmask;
9162
9163     /* If set and oset are both null, then things are badly wrong. Bail out. */
9164     if ((oset == NULL) && (set == NULL)) {
9165       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9166       return -1;
9167     }
9168
9169     /* If set's null, then we're just handling a fetch. */
9170     if (set == NULL) {
9171         tempmask = sigblock(0);
9172     }
9173     else {
9174       switch (how) {
9175       case SIG_SETMASK:
9176         tempmask = sigsetmask(*set);
9177         break;
9178       case SIG_BLOCK:
9179         tempmask = sigblock(*set);
9180         break;
9181       case SIG_UNBLOCK:
9182         tempmask = sigblock(0);
9183         sigsetmask(*oset & ~tempmask);
9184         break;
9185       default:
9186         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9187         return -1;
9188       }
9189     }
9190
9191     /* Did they pass us an oset? If so, stick our holding mask into it */
9192     if (oset)
9193       *oset = tempmask;
9194
9195     return 0;
9196 }
9197 /*}}}*/
9198 #endif  /* HOMEGROWN_POSIX_SIGNALS */
9199
9200
9201 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9202  * my_utime(), and flex_stat(), all of which operate on UTC unless
9203  * VMSISH_TIMES is true.
9204  */
9205 /* method used to handle UTC conversions:
9206  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
9207  */
9208 static int gmtime_emulation_type;
9209 /* number of secs to add to UTC POSIX-style time to get local time */
9210 static long int utc_offset_secs;
9211
9212 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9213  * in vmsish.h.  #undef them here so we can call the CRTL routines
9214  * directly.
9215  */
9216 #undef gmtime
9217 #undef localtime
9218 #undef time
9219
9220
9221 /*
9222  * DEC C previous to 6.0 corrupts the behavior of the /prefix
9223  * qualifier with the extern prefix pragma.  This provisional
9224  * hack circumvents this prefix pragma problem in previous
9225  * precompilers.
9226  */
9227 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9228 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9229 #    pragma __extern_prefix save
9230 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
9231 #    define gmtime decc$__utctz_gmtime
9232 #    define localtime decc$__utctz_localtime
9233 #    define time decc$__utc_time
9234 #    pragma __extern_prefix restore
9235
9236      struct tm *gmtime(), *localtime();
9237
9238 #  endif
9239 #endif
9240
9241
9242 static time_t toutc_dst(time_t loc) {
9243   struct tm *rsltmp;
9244
9245   if ((rsltmp = localtime(&loc)) == NULL) return -1;
9246   loc -= utc_offset_secs;
9247   if (rsltmp->tm_isdst) loc -= 3600;
9248   return loc;
9249 }
9250 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9251        ((gmtime_emulation_type || my_time(NULL)), \
9252        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9253        ((secs) - utc_offset_secs))))
9254
9255 static time_t toloc_dst(time_t utc) {
9256   struct tm *rsltmp;
9257
9258   utc += utc_offset_secs;
9259   if ((rsltmp = localtime(&utc)) == NULL) return -1;
9260   if (rsltmp->tm_isdst) utc += 3600;
9261   return utc;
9262 }
9263 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9264        ((gmtime_emulation_type || my_time(NULL)), \
9265        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9266        ((secs) + utc_offset_secs))))
9267
9268 #ifndef RTL_USES_UTC
9269 /*
9270
9271     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
9272         DST starts on 1st sun of april      at 02:00  std time
9273             ends on last sun of october     at 02:00  dst time
9274     see the UCX management command reference, SET CONFIG TIMEZONE
9275     for formatting info.
9276
9277     No, it's not as general as it should be, but then again, NOTHING
9278     will handle UK times in a sensible way.
9279 */
9280
9281
9282 /*
9283     parse the DST start/end info:
9284     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9285 */
9286
9287 static char *
9288 tz_parse_startend(char *s, struct tm *w, int *past)
9289 {
9290     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9291     int ly, dozjd, d, m, n, hour, min, sec, j, k;
9292     time_t g;
9293
9294     if (!s)    return 0;
9295     if (!w) return 0;
9296     if (!past) return 0;
9297
9298     ly = 0;
9299     if (w->tm_year % 4        == 0) ly = 1;
9300     if (w->tm_year % 100      == 0) ly = 0;
9301     if (w->tm_year+1900 % 400 == 0) ly = 1;
9302     if (ly) dinm[1]++;
9303
9304     dozjd = isdigit(*s);
9305     if (*s == 'J' || *s == 'j' || dozjd) {
9306         if (!dozjd && !isdigit(*++s)) return 0;
9307         d = *s++ - '0';
9308         if (isdigit(*s)) {
9309             d = d*10 + *s++ - '0';
9310             if (isdigit(*s)) {
9311                 d = d*10 + *s++ - '0';
9312             }
9313         }
9314         if (d == 0) return 0;
9315         if (d > 366) return 0;
9316         d--;
9317         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
9318         g = d * 86400;
9319         dozjd = 1;
9320     } else if (*s == 'M' || *s == 'm') {
9321         if (!isdigit(*++s)) return 0;
9322         m = *s++ - '0';
9323         if (isdigit(*s)) m = 10*m + *s++ - '0';
9324         if (*s != '.') return 0;
9325         if (!isdigit(*++s)) return 0;
9326         n = *s++ - '0';
9327         if (n < 1 || n > 5) return 0;
9328         if (*s != '.') return 0;
9329         if (!isdigit(*++s)) return 0;
9330         d = *s++ - '0';
9331         if (d > 6) return 0;
9332     }
9333
9334     if (*s == '/') {
9335         if (!isdigit(*++s)) return 0;
9336         hour = *s++ - '0';
9337         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9338         if (*s == ':') {
9339             if (!isdigit(*++s)) return 0;
9340             min = *s++ - '0';
9341             if (isdigit(*s)) min = 10*min + *s++ - '0';
9342             if (*s == ':') {
9343                 if (!isdigit(*++s)) return 0;
9344                 sec = *s++ - '0';
9345                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9346             }
9347         }
9348     } else {
9349         hour = 2;
9350         min = 0;
9351         sec = 0;
9352     }
9353
9354     if (dozjd) {
9355         if (w->tm_yday < d) goto before;
9356         if (w->tm_yday > d) goto after;
9357     } else {
9358         if (w->tm_mon+1 < m) goto before;
9359         if (w->tm_mon+1 > m) goto after;
9360
9361         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
9362         k = d - j; /* mday of first d */
9363         if (k <= 0) k += 7;
9364         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
9365         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9366         if (w->tm_mday < k) goto before;
9367         if (w->tm_mday > k) goto after;
9368     }
9369
9370     if (w->tm_hour < hour) goto before;
9371     if (w->tm_hour > hour) goto after;
9372     if (w->tm_min  < min)  goto before;
9373     if (w->tm_min  > min)  goto after;
9374     if (w->tm_sec  < sec)  goto before;
9375     goto after;
9376
9377 before:
9378     *past = 0;
9379     return s;
9380 after:
9381     *past = 1;
9382     return s;
9383 }
9384
9385
9386
9387
9388 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
9389
9390 static char *
9391 tz_parse_offset(char *s, int *offset)
9392 {
9393     int hour = 0, min = 0, sec = 0;
9394     int neg = 0;
9395     if (!s) return 0;
9396     if (!offset) return 0;
9397
9398     if (*s == '-') {neg++; s++;}
9399     if (*s == '+') s++;
9400     if (!isdigit(*s)) return 0;
9401     hour = *s++ - '0';
9402     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
9403     if (hour > 24) return 0;
9404     if (*s == ':') {
9405         if (!isdigit(*++s)) return 0;
9406         min = *s++ - '0';
9407         if (isdigit(*s)) min = min*10 + (*s++ - '0');
9408         if (min > 59) return 0;
9409         if (*s == ':') {
9410             if (!isdigit(*++s)) return 0;
9411             sec = *s++ - '0';
9412             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
9413             if (sec > 59) return 0;
9414         }
9415     }
9416
9417     *offset = (hour*60+min)*60 + sec;
9418     if (neg) *offset = -*offset;
9419     return s;
9420 }
9421
9422 /*
9423     input time is w, whatever type of time the CRTL localtime() uses.
9424     sets dst, the zone, and the gmtoff (seconds)
9425
9426     caches the value of TZ and UCX$TZ env variables; note that
9427     my_setenv looks for these and sets a flag if they're changed
9428     for efficiency.
9429
9430     We have to watch out for the "australian" case (dst starts in
9431     october, ends in april)...flagged by "reverse" and checked by
9432     scanning through the months of the previous year.
9433
9434 */
9435
9436 static int
9437 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
9438 {
9439     time_t when;
9440     struct tm *w2;
9441     char *s,*s2;
9442     char *dstzone, *tz, *s_start, *s_end;
9443     int std_off, dst_off, isdst;
9444     int y, dststart, dstend;
9445     static char envtz[1025];  /* longer than any logical, symbol, ... */
9446     static char ucxtz[1025];
9447     static char reversed = 0;
9448
9449     if (!w) return 0;
9450
9451     if (tz_updated) {
9452         tz_updated = 0;
9453         reversed = -1;  /* flag need to check  */
9454         envtz[0] = ucxtz[0] = '\0';
9455         tz = my_getenv("TZ",0);
9456         if (tz) strcpy(envtz, tz);
9457         tz = my_getenv("UCX$TZ",0);
9458         if (tz) strcpy(ucxtz, tz);
9459         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
9460     }
9461     tz = envtz;
9462     if (!*tz) tz = ucxtz;
9463
9464     s = tz;
9465     while (isalpha(*s)) s++;
9466     s = tz_parse_offset(s, &std_off);
9467     if (!s) return 0;
9468     if (!*s) {                  /* no DST, hurray we're done! */
9469         isdst = 0;
9470         goto done;
9471     }
9472
9473     dstzone = s;
9474     while (isalpha(*s)) s++;
9475     s2 = tz_parse_offset(s, &dst_off);
9476     if (s2) {
9477         s = s2;
9478     } else {
9479         dst_off = std_off - 3600;
9480     }
9481
9482     if (!*s) {      /* default dst start/end?? */
9483         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
9484             s = strchr(ucxtz,',');
9485         }
9486         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
9487     }
9488     if (*s != ',') return 0;
9489
9490     when = *w;
9491     when = _toutc(when);      /* convert to utc */
9492     when = when - std_off;    /* convert to pseudolocal time*/
9493
9494     w2 = localtime(&when);
9495     y = w2->tm_year;
9496     s_start = s+1;
9497     s = tz_parse_startend(s_start,w2,&dststart);
9498     if (!s) return 0;
9499     if (*s != ',') return 0;
9500
9501     when = *w;
9502     when = _toutc(when);      /* convert to utc */
9503     when = when - dst_off;    /* convert to pseudolocal time*/
9504     w2 = localtime(&when);
9505     if (w2->tm_year != y) {   /* spans a year, just check one time */
9506         when += dst_off - std_off;
9507         w2 = localtime(&when);
9508     }
9509     s_end = s+1;
9510     s = tz_parse_startend(s_end,w2,&dstend);
9511     if (!s) return 0;
9512
9513     if (reversed == -1) {  /* need to check if start later than end */
9514         int j, ds, de;
9515
9516         when = *w;
9517         if (when < 2*365*86400) {
9518             when += 2*365*86400;
9519         } else {
9520             when -= 365*86400;
9521         }
9522         w2 =localtime(&when);
9523         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
9524
9525         for (j = 0; j < 12; j++) {
9526             w2 =localtime(&when);
9527             tz_parse_startend(s_start,w2,&ds);
9528             tz_parse_startend(s_end,w2,&de);
9529             if (ds != de) break;
9530             when += 30*86400;
9531         }
9532         reversed = 0;
9533         if (de && !ds) reversed = 1;
9534     }
9535
9536     isdst = dststart && !dstend;
9537     if (reversed) isdst = dststart  || !dstend;
9538
9539 done:
9540     if (dst)    *dst = isdst;
9541     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9542     if (isdst)  tz = dstzone;
9543     if (zone) {
9544         while(isalpha(*tz))  *zone++ = *tz++;
9545         *zone = '\0';
9546     }
9547     return 1;
9548 }
9549
9550 #endif /* !RTL_USES_UTC */
9551
9552 /* my_time(), my_localtime(), my_gmtime()
9553  * By default traffic in UTC time values, using CRTL gmtime() or
9554  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9555  * Note: We need to use these functions even when the CRTL has working
9556  * UTC support, since they also handle C<use vmsish qw(times);>
9557  *
9558  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
9559  * Modified by Charles Bailey <bailey@newman.upenn.edu>
9560  */
9561
9562 /*{{{time_t my_time(time_t *timep)*/
9563 time_t Perl_my_time(pTHX_ time_t *timep)
9564 {
9565   time_t when;
9566   struct tm *tm_p;
9567
9568   if (gmtime_emulation_type == 0) {
9569     int dstnow;
9570     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
9571                               /* results of calls to gmtime() and localtime() */
9572                               /* for same &base */
9573
9574     gmtime_emulation_type++;
9575     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9576       char off[LNM$C_NAMLENGTH+1];;
9577
9578       gmtime_emulation_type++;
9579       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9580         gmtime_emulation_type++;
9581         utc_offset_secs = 0;
9582         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9583       }
9584       else { utc_offset_secs = atol(off); }
9585     }
9586     else { /* We've got a working gmtime() */
9587       struct tm gmt, local;
9588
9589       gmt = *tm_p;
9590       tm_p = localtime(&base);
9591       local = *tm_p;
9592       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
9593       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9594       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
9595       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
9596     }
9597   }
9598
9599   when = time(NULL);
9600 # ifdef VMSISH_TIME
9601 # ifdef RTL_USES_UTC
9602   if (VMSISH_TIME) when = _toloc(when);
9603 # else
9604   if (!VMSISH_TIME) when = _toutc(when);
9605 # endif
9606 # endif
9607   if (timep != NULL) *timep = when;
9608   return when;
9609
9610 }  /* end of my_time() */
9611 /*}}}*/
9612
9613
9614 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9615 struct tm *
9616 Perl_my_gmtime(pTHX_ const time_t *timep)
9617 {
9618   char *p;
9619   time_t when;
9620   struct tm *rsltmp;
9621
9622   if (timep == NULL) {
9623     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9624     return NULL;
9625   }
9626   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9627
9628   when = *timep;
9629 # ifdef VMSISH_TIME
9630   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9631 #  endif
9632 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
9633   return gmtime(&when);
9634 # else
9635   /* CRTL localtime() wants local time as input, so does no tz correction */
9636   rsltmp = localtime(&when);
9637   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
9638   return rsltmp;
9639 #endif
9640 }  /* end of my_gmtime() */
9641 /*}}}*/
9642
9643
9644 /*{{{struct tm *my_localtime(const time_t *timep)*/
9645 struct tm *
9646 Perl_my_localtime(pTHX_ const time_t *timep)
9647 {
9648   time_t when, whenutc;
9649   struct tm *rsltmp;
9650   int dst, offset;
9651
9652   if (timep == NULL) {
9653     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9654     return NULL;
9655   }
9656   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9657   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9658
9659   when = *timep;
9660 # ifdef RTL_USES_UTC
9661 # ifdef VMSISH_TIME
9662   if (VMSISH_TIME) when = _toutc(when);
9663 # endif
9664   /* CRTL localtime() wants UTC as input, does tz correction itself */
9665   return localtime(&when);
9666
9667 # else /* !RTL_USES_UTC */
9668   whenutc = when;
9669 # ifdef VMSISH_TIME
9670   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
9671   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
9672 # endif
9673   dst = -1;
9674 #ifndef RTL_USES_UTC
9675   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
9676       when = whenutc - offset;                   /* pseudolocal time*/
9677   }
9678 # endif
9679   /* CRTL localtime() wants local time as input, so does no tz correction */
9680   rsltmp = localtime(&when);
9681   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9682   return rsltmp;
9683 # endif
9684
9685 } /*  end of my_localtime() */
9686 /*}}}*/
9687
9688 /* Reset definitions for later calls */
9689 #define gmtime(t)    my_gmtime(t)
9690 #define localtime(t) my_localtime(t)
9691 #define time(t)      my_time(t)
9692
9693
9694 /* my_utime - update modification time of a file
9695  * calling sequence is identical to POSIX utime(), but under
9696  * VMS only the modification time is changed; ODS-2 does not
9697  * maintain access times.  Restrictions differ from the POSIX
9698  * definition in that the time can be changed as long as the
9699  * caller has permission to execute the necessary IO$_MODIFY $QIO;
9700  * no separate checks are made to insure that the caller is the
9701  * owner of the file or has special privs enabled.
9702  * Code here is based on Joe Meadows' FILE utility.
9703  */
9704
9705 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9706  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
9707  * in 100 ns intervals.
9708  */
9709 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9710
9711 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9712 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9713 {
9714   register int i;
9715   int sts;
9716   long int bintime[2], len = 2, lowbit, unixtime,
9717            secscale = 10000000; /* seconds --> 100 ns intervals */
9718   unsigned long int chan, iosb[2], retsts;
9719   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9720   struct FAB myfab = cc$rms_fab;
9721   struct NAM mynam = cc$rms_nam;
9722 #if defined (__DECC) && defined (__VAX)
9723   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9724    * at least through VMS V6.1, which causes a type-conversion warning.
9725    */
9726 #  pragma message save
9727 #  pragma message disable cvtdiftypes
9728 #endif
9729   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9730   struct fibdef myfib;
9731 #if defined (__DECC) && defined (__VAX)
9732   /* This should be right after the declaration of myatr, but due
9733    * to a bug in VAX DEC C, this takes effect a statement early.
9734    */
9735 #  pragma message restore
9736 #endif
9737   /* cast ok for read only parameter */
9738   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9739                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9740                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9741
9742   if (file == NULL || *file == '\0') {
9743     set_errno(ENOENT);
9744     set_vaxc_errno(LIB$_INVARG);
9745     return -1;
9746   }
9747   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
9748
9749   if (utimes != NULL) {
9750     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
9751      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9752      * Since time_t is unsigned long int, and lib$emul takes a signed long int
9753      * as input, we force the sign bit to be clear by shifting unixtime right
9754      * one bit, then multiplying by an extra factor of 2 in lib$emul().
9755      */
9756     lowbit = (utimes->modtime & 1) ? secscale : 0;
9757     unixtime = (long int) utimes->modtime;
9758 #   ifdef VMSISH_TIME
9759     /* If input was UTC; convert to local for sys svc */
9760     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9761 #   endif
9762     unixtime >>= 1;  secscale <<= 1;
9763     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9764     if (!(retsts & 1)) {
9765       set_errno(EVMSERR);
9766       set_vaxc_errno(retsts);
9767       return -1;
9768     }
9769     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9770     if (!(retsts & 1)) {
9771       set_errno(EVMSERR);
9772       set_vaxc_errno(retsts);
9773       return -1;
9774     }
9775   }
9776   else {
9777     /* Just get the current time in VMS format directly */
9778     retsts = sys$gettim(bintime);
9779     if (!(retsts & 1)) {
9780       set_errno(EVMSERR);
9781       set_vaxc_errno(retsts);
9782       return -1;
9783     }
9784   }
9785
9786   myfab.fab$l_fna = vmsspec;
9787   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9788   myfab.fab$l_nam = &mynam;
9789   mynam.nam$l_esa = esa;
9790   mynam.nam$b_ess = (unsigned char) sizeof esa;
9791   mynam.nam$l_rsa = rsa;
9792   mynam.nam$b_rss = (unsigned char) sizeof rsa;
9793   if (decc_efs_case_preserve)
9794       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9795
9796   /* Look for the file to be affected, letting RMS parse the file
9797    * specification for us as well.  I have set errno using only
9798    * values documented in the utime() man page for VMS POSIX.
9799    */
9800   retsts = sys$parse(&myfab,0,0);
9801   if (!(retsts & 1)) {
9802     set_vaxc_errno(retsts);
9803     if      (retsts == RMS$_PRV) set_errno(EACCES);
9804     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9805     else                         set_errno(EVMSERR);
9806     return -1;
9807   }
9808   retsts = sys$search(&myfab,0,0);
9809   if (!(retsts & 1)) {
9810     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9811     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9812     set_vaxc_errno(retsts);
9813     if      (retsts == RMS$_PRV) set_errno(EACCES);
9814     else if (retsts == RMS$_FNF) set_errno(ENOENT);
9815     else                         set_errno(EVMSERR);
9816     return -1;
9817   }
9818
9819   devdsc.dsc$w_length = mynam.nam$b_dev;
9820   /* cast ok for read only parameter */
9821   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9822
9823   retsts = sys$assign(&devdsc,&chan,0,0);
9824   if (!(retsts & 1)) {
9825     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9826     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9827     set_vaxc_errno(retsts);
9828     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
9829     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
9830     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
9831     else                               set_errno(EVMSERR);
9832     return -1;
9833   }
9834
9835   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9836   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9837
9838   memset((void *) &myfib, 0, sizeof myfib);
9839 #if defined(__DECC) || defined(__DECCXX)
9840   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9841   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9842   /* This prevents the revision time of the file being reset to the current
9843    * time as a result of our IO$_MODIFY $QIO. */
9844   myfib.fib$l_acctl = FIB$M_NORECORD;
9845 #else
9846   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9847   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9848   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9849 #endif
9850   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9851   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9852   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9853   _ckvmssts(sys$dassgn(chan));
9854   if (retsts & 1) retsts = iosb[0];
9855   if (!(retsts & 1)) {
9856     set_vaxc_errno(retsts);
9857     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9858     else                      set_errno(EVMSERR);
9859     return -1;
9860   }
9861
9862   return 0;
9863 }  /* end of my_utime() */
9864 /*}}}*/
9865
9866 /*
9867  * flex_stat, flex_lstat, flex_fstat
9868  * basic stat, but gets it right when asked to stat
9869  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9870  */
9871
9872 #ifndef _USE_STD_STAT
9873 /* encode_dev packs a VMS device name string into an integer to allow
9874  * simple comparisons. This can be used, for example, to check whether two
9875  * files are located on the same device, by comparing their encoded device
9876  * names. Even a string comparison would not do, because stat() reuses the
9877  * device name buffer for each call; so without encode_dev, it would be
9878  * necessary to save the buffer and use strcmp (this would mean a number of
9879  * changes to the standard Perl code, to say nothing of what a Perl script
9880  * would have to do.
9881  *
9882  * The device lock id, if it exists, should be unique (unless perhaps compared
9883  * with lock ids transferred from other nodes). We have a lock id if the disk is
9884  * mounted cluster-wide, which is when we tend to get long (host-qualified)
9885  * device names. Thus we use the lock id in preference, and only if that isn't
9886  * available, do we try to pack the device name into an integer (flagged by
9887  * the sign bit (LOCKID_MASK) being set).
9888  *
9889  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9890  * name and its encoded form, but it seems very unlikely that we will find
9891  * two files on different disks that share the same encoded device names,
9892  * and even more remote that they will share the same file id (if the test
9893  * is to check for the same file).
9894  *
9895  * A better method might be to use sys$device_scan on the first call, and to
9896  * search for the device, returning an index into the cached array.
9897  * The number returned would be more intelligable.
9898  * This is probably not worth it, and anyway would take quite a bit longer
9899  * on the first call.
9900  */
9901 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
9902 static mydev_t encode_dev (pTHX_ const char *dev)
9903 {
9904   int i;
9905   unsigned long int f;
9906   mydev_t enc;
9907   char c;
9908   const char *q;
9909
9910   if (!dev || !dev[0]) return 0;
9911
9912 #if LOCKID_MASK
9913   {
9914     struct dsc$descriptor_s dev_desc;
9915     unsigned long int status, lockid, item = DVI$_LOCKID;
9916
9917     /* For cluster-mounted disks, the disk lock identifier is unique, so we
9918        can try that first. */
9919     dev_desc.dsc$w_length =  strlen (dev);
9920     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
9921     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
9922     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
9923     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9924     if (lockid) return (lockid & ~LOCKID_MASK);
9925   }
9926 #endif
9927
9928   /* Otherwise we try to encode the device name */
9929   enc = 0;
9930   f = 1;
9931   i = 0;
9932   for (q = dev + strlen(dev); q--; q >= dev) {
9933     if (isdigit (*q))
9934       c= (*q) - '0';
9935     else if (isalpha (toupper (*q)))
9936       c= toupper (*q) - 'A' + (char)10;
9937     else
9938       continue; /* Skip '$'s */
9939     i++;
9940     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
9941     if (i>1) f *= 36;
9942     enc += f * (unsigned long int) c;
9943   }
9944   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
9945
9946 }  /* end of encode_dev() */
9947 #endif
9948
9949 static char namecache[NAM$C_MAXRSS+1];
9950
9951 static int
9952 is_null_device(name)
9953     const char *name;
9954 {
9955   if (decc_bug_devnull != 0) {
9956     if (strncmp("/dev/null", name, 9) == 0)
9957       return 1;
9958   }
9959     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9960        The underscore prefix, controller letter, and unit number are
9961        independently optional; for our purposes, the colon punctuation
9962        is not.  The colon can be trailed by optional directory and/or
9963        filename, but two consecutive colons indicates a nodename rather
9964        than a device.  [pr]  */
9965   if (*name == '_') ++name;
9966   if (tolower(*name++) != 'n') return 0;
9967   if (tolower(*name++) != 'l') return 0;
9968   if (tolower(*name) == 'a') ++name;
9969   if (*name == '0') ++name;
9970   return (*name++ == ':') && (*name != ':');
9971 }
9972
9973 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
9974 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9975  * subset of the applicable information.
9976  */
9977 bool
9978 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
9979 {
9980   char fname_phdev[NAM$C_MAXRSS+1];
9981 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9982   /* Namecache not workable with symbolic links, as symbolic links do
9983    *  not have extensions and directories do in VMS mode.  So in order
9984    *  to test this, the did and ino_t must be used.
9985    *
9986    * Fix-me - Hide the information in the new stat structure
9987    *          Get rid of the namecache.
9988    */
9989   if (decc_posix_compliant_pathnames == 0)
9990 #endif
9991       if (statbufp == &PL_statcache)
9992           return cando_by_name(bit,effective,namecache);
9993   {
9994     char fname[NAM$C_MAXRSS+1];
9995     unsigned long int retsts;
9996     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9997                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9998
9999     /* If the struct mystat is stale, we're OOL; stat() overwrites the
10000        device name on successive calls */
10001     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
10002     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
10003     namdsc.dsc$a_pointer = fname;
10004     namdsc.dsc$w_length = sizeof fname - 1;
10005
10006     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
10007                              &namdsc,&namdsc.dsc$w_length,0,0);
10008     if (retsts & 1) {
10009       fname[namdsc.dsc$w_length] = '\0';
10010 /*
10011  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
10012  * but if someone has redefined that logical, Perl gets very lost.  Since
10013  * we have the physical device name from the stat buffer, just paste it on.
10014  */
10015       strcpy( fname_phdev, statbufp->st_devnam );
10016       strcat( fname_phdev, strrchr(fname, ':') );
10017
10018       return cando_by_name(bit,effective,fname_phdev);
10019     }
10020     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
10021       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
10022       return FALSE;
10023     }
10024     _ckvmssts(retsts);
10025     return FALSE;  /* Should never get to here */
10026   }
10027 }  /* end of cando() */
10028 /*}}}*/
10029
10030
10031 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10032 I32
10033 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10034 {
10035   static char usrname[L_cuserid];
10036   static struct dsc$descriptor_s usrdsc =
10037          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10038   char vmsname[NAM$C_MAXRSS+1];
10039   char *fileified;
10040   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
10041   unsigned short int retlen, trnlnm_iter_count;
10042   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10043   union prvdef curprv;
10044   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10045          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
10046   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10047          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10048          {0,0,0,0}};
10049   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10050          {0,0,0,0}};
10051   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10052
10053   if (!fname || !*fname) return FALSE;
10054   /* Make sure we expand logical names, since sys$check_access doesn't */
10055   fileified = PerlMem_malloc(VMS_MAXRSS);
10056   if (!strpbrk(fname,"/]>:")) {
10057     strcpy(fileified,fname);
10058     trnlnm_iter_count = 0;
10059     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10060         trnlnm_iter_count++;
10061         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10062     }
10063     fname = fileified;
10064   }
10065   if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS)) {
10066     PerlMem_free(fileified);
10067     return FALSE;
10068   }
10069   retlen = namdsc.dsc$w_length = strlen(vmsname);
10070   namdsc.dsc$a_pointer = vmsname;
10071   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10072       vmsname[retlen-1] == ':') {
10073     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
10074     namdsc.dsc$w_length = strlen(fileified);
10075     namdsc.dsc$a_pointer = fileified;
10076   }
10077
10078   switch (bit) {
10079     case S_IXUSR: case S_IXGRP: case S_IXOTH:
10080       access = ARM$M_EXECUTE; break;
10081     case S_IRUSR: case S_IRGRP: case S_IROTH:
10082       access = ARM$M_READ; break;
10083     case S_IWUSR: case S_IWGRP: case S_IWOTH:
10084       access = ARM$M_WRITE; break;
10085     case S_IDUSR: case S_IDGRP: case S_IDOTH:
10086       access = ARM$M_DELETE; break;
10087     default:
10088       PerlMem_free(fileified);
10089       return FALSE;
10090   }
10091
10092   /* Before we call $check_access, create a user profile with the current
10093    * process privs since otherwise it just uses the default privs from the
10094    * UAF and might give false positives or negatives.  This only works on
10095    * VMS versions v6.0 and later since that's when sys$create_user_profile
10096    * became available.
10097    */
10098
10099   /* get current process privs and username */
10100   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10101   _ckvmssts(iosb[0]);
10102
10103 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10104
10105   /* find out the space required for the profile */
10106   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10107                                     &usrprodsc.dsc$w_length,0));
10108
10109   /* allocate space for the profile and get it filled in */
10110   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10111   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10112   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10113                                     &usrprodsc.dsc$w_length,0));
10114
10115   /* use the profile to check access to the file; free profile & analyze results */
10116   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10117   PerlMem_free(usrprodsc.dsc$a_pointer);
10118   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10119
10120 #else
10121
10122   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10123
10124 #endif
10125
10126   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
10127       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10128       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10129     set_vaxc_errno(retsts);
10130     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10131     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10132     else set_errno(ENOENT);
10133     PerlMem_free(fileified);
10134     return FALSE;
10135   }
10136   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10137     PerlMem_free(fileified);
10138     return TRUE;
10139   }
10140   _ckvmssts(retsts);
10141
10142   PerlMem_free(fileified);
10143   return FALSE;  /* Should never get here */
10144
10145 }  /* end of cando_by_name() */
10146 /*}}}*/
10147
10148
10149 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10150 int
10151 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10152 {
10153   if (!fstat(fd,(stat_t *) statbufp)) {
10154     if (statbufp == (Stat_t *) &PL_statcache) {
10155     char *cptr;
10156
10157         /* Save name for cando by name in VMS format */
10158         cptr = getname(fd, namecache, 1);
10159
10160         /* This should not happen, but just in case */
10161         if (cptr == NULL)
10162            namecache[0] = '\0';
10163     }
10164
10165     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10166 #ifndef _USE_STD_STAT
10167     strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
10168     statbufp->st_devnam[63] = 0;
10169     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
10170 #else
10171     /* todo:
10172      * The device is only encoded so that Perl_cando can use it to
10173      * look up ACLS.  So rmsexpand it to the 255 character version
10174      * and store it in ->st_devnam.  rmsexpand needs to be fixed
10175      * for long filenames and symbolic links first.  This also seems
10176      * to remove the need for a namecache that could be stale.
10177      */
10178 #endif
10179
10180 #   ifdef RTL_USES_UTC
10181 #   ifdef VMSISH_TIME
10182     if (VMSISH_TIME) {
10183       statbufp->st_mtime = _toloc(statbufp->st_mtime);
10184       statbufp->st_atime = _toloc(statbufp->st_atime);
10185       statbufp->st_ctime = _toloc(statbufp->st_ctime);
10186     }
10187 #   endif
10188 #   else
10189 #   ifdef VMSISH_TIME
10190     if (!VMSISH_TIME) { /* Return UTC instead of local time */
10191 #   else
10192     if (1) {
10193 #   endif
10194       statbufp->st_mtime = _toutc(statbufp->st_mtime);
10195       statbufp->st_atime = _toutc(statbufp->st_atime);
10196       statbufp->st_ctime = _toutc(statbufp->st_ctime);
10197     }
10198 #endif
10199     return 0;
10200   }
10201   return -1;
10202
10203 }  /* end of flex_fstat() */
10204 /*}}}*/
10205
10206 #if !defined(__VAX) && __CRTL_VER >= 80200000
10207 #ifdef lstat
10208 #undef lstat
10209 #endif
10210 #else
10211 #ifdef lstat
10212 #undef lstat
10213 #endif
10214 #define lstat(_x, _y) stat(_x, _y)
10215 #endif
10216
10217 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
10218
10219 static int
10220 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10221 {
10222     char fileified[NAM$C_MAXRSS+1];
10223     char temp_fspec[NAM$C_MAXRSS+300];
10224     int retval = -1;
10225     int saved_errno, saved_vaxc_errno;
10226
10227     if (!fspec) return retval;
10228     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10229     strcpy(temp_fspec, fspec);
10230     if (statbufp == (Stat_t *) &PL_statcache)
10231       do_tovmsspec(temp_fspec,namecache,0);
10232     if (decc_bug_devnull != 0) {
10233       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10234         memset(statbufp,0,sizeof *statbufp);
10235         statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
10236         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10237         statbufp->st_uid = 0x00010001;
10238         statbufp->st_gid = 0x0001;
10239         time((time_t *)&statbufp->st_mtime);
10240         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10241         return 0;
10242       }
10243     }
10244
10245     /* Try for a directory name first.  If fspec contains a filename without
10246      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10247      * and sea:[wine.dark]water. exist, we prefer the directory here.
10248      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10249      * not sea:[wine.dark]., if the latter exists.  If the intended target is
10250      * the file with null type, specify this by calling flex_stat() with
10251      * a '.' at the end of fspec.
10252      *
10253      * If we are in Posix filespec mode, accept the filename as is.
10254      */
10255 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10256   if (decc_posix_compliant_pathnames == 0) {
10257 #endif
10258     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
10259       if (lstat_flag == 0)
10260         retval = stat(fileified,(stat_t *) statbufp);
10261       else
10262         retval = lstat(fileified,(stat_t *) statbufp);
10263       if (!retval && statbufp == (Stat_t *) &PL_statcache)
10264         strcpy(namecache,fileified);
10265     }
10266     if (retval) {
10267       if (lstat_flag == 0)
10268         retval = stat(temp_fspec,(stat_t *) statbufp);
10269       else
10270         retval = lstat(temp_fspec,(stat_t *) statbufp);
10271     }
10272 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10273   } else {
10274     if (lstat_flag == 0)
10275       retval = stat(temp_fspec,(stat_t *) statbufp);
10276     else
10277       retval = lstat(temp_fspec,(stat_t *) statbufp);
10278   }
10279 #endif
10280     if (!retval) {
10281       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10282 #ifndef _USE_STD_STAT
10283       strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
10284       statbufp->st_devnam[63] = 0;
10285       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
10286 #else
10287     /* todo:
10288      * The device is only encoded so that Perl_cando can use it to
10289      * look up ACLS.  So rmsexpand it to the 255 character version
10290      * and store it in ->st_devnam.  rmsexpand needs to be fixed
10291      * for long filenames and symbolic links first.  This also seems
10292      * to remove the need for a namecache that could be stale.
10293      */
10294 #endif
10295 #     ifdef RTL_USES_UTC
10296 #     ifdef VMSISH_TIME
10297       if (VMSISH_TIME) {
10298         statbufp->st_mtime = _toloc(statbufp->st_mtime);
10299         statbufp->st_atime = _toloc(statbufp->st_atime);
10300         statbufp->st_ctime = _toloc(statbufp->st_ctime);
10301       }
10302 #     endif
10303 #     else
10304 #     ifdef VMSISH_TIME
10305       if (!VMSISH_TIME) { /* Return UTC instead of local time */
10306 #     else
10307       if (1) {
10308 #     endif
10309         statbufp->st_mtime = _toutc(statbufp->st_mtime);
10310         statbufp->st_atime = _toutc(statbufp->st_atime);
10311         statbufp->st_ctime = _toutc(statbufp->st_ctime);
10312       }
10313 #     endif
10314     }
10315     /* If we were successful, leave errno where we found it */
10316     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10317     return retval;
10318
10319 }  /* end of flex_stat_int() */
10320
10321
10322 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10323 int
10324 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10325 {
10326    return flex_stat_int(fspec, statbufp, 0);
10327 }
10328 /*}}}*/
10329
10330 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10331 int
10332 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10333 {
10334    return flex_stat_int(fspec, statbufp, 1);
10335 }
10336 /*}}}*/
10337
10338
10339 /*{{{char *my_getlogin()*/
10340 /* VMS cuserid == Unix getlogin, except calling sequence */
10341 char *
10342 my_getlogin(void)
10343 {
10344     static char user[L_cuserid];
10345     return cuserid(user);
10346 }
10347 /*}}}*/
10348
10349
10350 /*  rmscopy - copy a file using VMS RMS routines
10351  *
10352  *  Copies contents and attributes of spec_in to spec_out, except owner
10353  *  and protection information.  Name and type of spec_in are used as
10354  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
10355  *  should try to propagate timestamps from the input file to the output file.
10356  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
10357  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
10358  *  propagated to the output file at creation iff the output file specification
10359  *  did not contain an explicit name or type, and the revision date is always
10360  *  updated at the end of the copy operation.  If it is greater than 0, then
10361  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
10362  *  other than the revision date should be propagated, and bit 1 indicates
10363  *  that the revision date should be propagated.
10364  *
10365  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
10366  *
10367  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
10368  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
10369  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
10370  * as part of the Perl standard distribution under the terms of the
10371  * GNU General Public License or the Perl Artistic License.  Copies
10372  * of each may be found in the Perl standard distribution.
10373  */ /* FIXME */
10374 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
10375 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
10376 int
10377 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10378 {
10379     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
10380          rsa[NAM$C_MAXRSS], ubf[32256];
10381     unsigned long int i, sts, sts2;
10382     struct FAB fab_in, fab_out;
10383     struct RAB rab_in, rab_out;
10384     struct NAM nam;
10385     struct XABDAT xabdat;
10386     struct XABFHC xabfhc;
10387     struct XABRDT xabrdt;
10388     struct XABSUM xabsum;
10389
10390     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
10391         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10392       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10393       return 0;
10394     }
10395
10396     fab_in = cc$rms_fab;
10397     fab_in.fab$l_fna = vmsin;
10398     fab_in.fab$b_fns = strlen(vmsin);
10399     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10400     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10401     fab_in.fab$l_fop = FAB$M_SQO;
10402     fab_in.fab$l_nam =  &nam;
10403     fab_in.fab$l_xab = (void *) &xabdat;
10404
10405     nam = cc$rms_nam;
10406     nam.nam$l_rsa = rsa;
10407     nam.nam$b_rss = sizeof(rsa);
10408     nam.nam$l_esa = esa;
10409     nam.nam$b_ess = sizeof (esa);
10410     nam.nam$b_esl = nam.nam$b_rsl = 0;
10411 #ifdef NAM$M_NO_SHORT_UPCASE
10412     if (decc_efs_case_preserve)
10413         nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10414 #endif
10415
10416     xabdat = cc$rms_xabdat;        /* To get creation date */
10417     xabdat.xab$l_nxt = (void *) &xabfhc;
10418
10419     xabfhc = cc$rms_xabfhc;        /* To get record length */
10420     xabfhc.xab$l_nxt = (void *) &xabsum;
10421
10422     xabsum = cc$rms_xabsum;        /* To get key and area information */
10423
10424     if (!((sts = sys$open(&fab_in)) & 1)) {
10425       set_vaxc_errno(sts);
10426       switch (sts) {
10427         case RMS$_FNF: case RMS$_DNF:
10428           set_errno(ENOENT); break;
10429         case RMS$_DIR:
10430           set_errno(ENOTDIR); break;
10431         case RMS$_DEV:
10432           set_errno(ENODEV); break;
10433         case RMS$_SYN:
10434           set_errno(EINVAL); break;
10435         case RMS$_PRV:
10436           set_errno(EACCES); break;
10437         default:
10438           set_errno(EVMSERR);
10439       }
10440       return 0;
10441     }
10442
10443     fab_out = fab_in;
10444     fab_out.fab$w_ifi = 0;
10445     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10446     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10447     fab_out.fab$l_fop = FAB$M_SQO;
10448     fab_out.fab$l_fna = vmsout;
10449     fab_out.fab$b_fns = strlen(vmsout);
10450     fab_out.fab$l_dna = nam.nam$l_name;
10451     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
10452
10453     if (preserve_dates == 0) {  /* Act like DCL COPY */
10454       nam.nam$b_nop |= NAM$M_SYNCHK;
10455       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10456       if (!((sts = sys$parse(&fab_out)) & 1)) {
10457         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10458         set_vaxc_errno(sts);
10459         return 0;
10460       }
10461       fab_out.fab$l_xab = (void *) &xabdat;
10462       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10463     }
10464     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
10465     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10466       preserve_dates =0;      /* bitmask from this point forward   */
10467
10468     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10469     if (!((sts = sys$create(&fab_out)) & 1)) {
10470       set_vaxc_errno(sts);
10471       switch (sts) {
10472         case RMS$_DNF:
10473           set_errno(ENOENT); break;
10474         case RMS$_DIR:
10475           set_errno(ENOTDIR); break;
10476         case RMS$_DEV:
10477           set_errno(ENODEV); break;
10478         case RMS$_SYN:
10479           set_errno(EINVAL); break;
10480         case RMS$_PRV:
10481           set_errno(EACCES); break;
10482         default:
10483           set_errno(EVMSERR);
10484       }
10485       return 0;
10486     }
10487     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10488     if (preserve_dates & 2) {
10489       /* sys$close() will process xabrdt, not xabdat */
10490       xabrdt = cc$rms_xabrdt;
10491 #ifndef __GNUC__
10492       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10493 #else
10494       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10495        * is unsigned long[2], while DECC & VAXC use a struct */
10496       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10497 #endif
10498       fab_out.fab$l_xab = (void *) &xabrdt;
10499     }
10500
10501     rab_in = cc$rms_rab;
10502     rab_in.rab$l_fab = &fab_in;
10503     rab_in.rab$l_rop = RAB$M_BIO;
10504     rab_in.rab$l_ubf = ubf;
10505     rab_in.rab$w_usz = sizeof ubf;
10506     if (!((sts = sys$connect(&rab_in)) & 1)) {
10507       sys$close(&fab_in); sys$close(&fab_out);
10508       set_errno(EVMSERR); set_vaxc_errno(sts);
10509       return 0;
10510     }
10511
10512     rab_out = cc$rms_rab;
10513     rab_out.rab$l_fab = &fab_out;
10514     rab_out.rab$l_rbf = ubf;
10515     if (!((sts = sys$connect(&rab_out)) & 1)) {
10516       sys$close(&fab_in); sys$close(&fab_out);
10517       set_errno(EVMSERR); set_vaxc_errno(sts);
10518       return 0;
10519     }
10520
10521     while ((sts = sys$read(&rab_in))) {  /* always true  */
10522       if (sts == RMS$_EOF) break;
10523       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10524       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10525         sys$close(&fab_in); sys$close(&fab_out);
10526         set_errno(EVMSERR); set_vaxc_errno(sts);
10527         return 0;
10528       }
10529     }
10530
10531     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10532     sys$close(&fab_in);  sys$close(&fab_out);
10533     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10534     if (!(sts & 1)) {
10535       set_errno(EVMSERR); set_vaxc_errno(sts);
10536       return 0;
10537     }
10538
10539     return 1;
10540
10541 }  /* end of rmscopy() */
10542 #else
10543 /* ODS-5 support version */
10544 int
10545 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10546 {
10547     char *vmsin, * vmsout, *esa, *esa_out,
10548          *rsa, *ubf;
10549     unsigned long int i, sts, sts2;
10550     struct FAB fab_in, fab_out;
10551     struct RAB rab_in, rab_out;
10552     struct NAML nam;
10553     struct NAML nam_out;
10554     struct XABDAT xabdat;
10555     struct XABFHC xabfhc;
10556     struct XABRDT xabrdt;
10557     struct XABSUM xabsum;
10558
10559     vmsin = PerlMem_malloc(VMS_MAXRSS);
10560     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
10561     vmsout = PerlMem_malloc(VMS_MAXRSS);
10562     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
10563     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
10564         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10565       PerlMem_free(vmsin);
10566       PerlMem_free(vmsout);
10567       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10568       return 0;
10569     }
10570
10571     esa = PerlMem_malloc(VMS_MAXRSS);
10572     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
10573     nam = cc$rms_naml;
10574     fab_in = cc$rms_fab;
10575     fab_in.fab$l_fna = (char *) -1;
10576     fab_in.fab$b_fns = 0;
10577     nam.naml$l_long_filename = vmsin;
10578     nam.naml$l_long_filename_size = strlen(vmsin);
10579     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10580     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10581     fab_in.fab$l_fop = FAB$M_SQO;
10582     fab_in.fab$l_naml =  &nam;
10583     fab_in.fab$l_xab = (void *) &xabdat;
10584
10585     rsa = PerlMem_malloc(VMS_MAXRSS);
10586     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
10587     nam.naml$l_rsa = NULL;
10588     nam.naml$b_rss = 0;
10589     nam.naml$l_long_result = rsa;
10590     nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10591     nam.naml$l_esa = NULL;
10592     nam.naml$b_ess = 0;
10593     nam.naml$l_long_expand = esa;
10594     nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10595     nam.naml$b_esl = nam.naml$b_rsl = 0;
10596     nam.naml$l_long_expand_size = 0;
10597     nam.naml$l_long_result_size = 0;
10598 #ifdef NAM$M_NO_SHORT_UPCASE
10599     if (decc_efs_case_preserve)
10600         nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10601 #endif
10602
10603     xabdat = cc$rms_xabdat;        /* To get creation date */
10604     xabdat.xab$l_nxt = (void *) &xabfhc;
10605
10606     xabfhc = cc$rms_xabfhc;        /* To get record length */
10607     xabfhc.xab$l_nxt = (void *) &xabsum;
10608
10609     xabsum = cc$rms_xabsum;        /* To get key and area information */
10610
10611     if (!((sts = sys$open(&fab_in)) & 1)) {
10612       PerlMem_free(vmsin);
10613       PerlMem_free(vmsout);
10614       PerlMem_free(esa);
10615       PerlMem_free(rsa);
10616       set_vaxc_errno(sts);
10617       switch (sts) {
10618         case RMS$_FNF: case RMS$_DNF:
10619           set_errno(ENOENT); break;
10620         case RMS$_DIR:
10621           set_errno(ENOTDIR); break;
10622         case RMS$_DEV:
10623           set_errno(ENODEV); break;
10624         case RMS$_SYN:
10625           set_errno(EINVAL); break;
10626         case RMS$_PRV:
10627           set_errno(EACCES); break;
10628         default:
10629           set_errno(EVMSERR);
10630       }
10631       return 0;
10632     }
10633
10634     nam_out = nam;
10635     fab_out = fab_in;
10636     fab_out.fab$w_ifi = 0;
10637     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10638     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10639     fab_out.fab$l_fop = FAB$M_SQO;
10640     fab_out.fab$l_naml = &nam_out;
10641     fab_out.fab$l_fna = (char *) -1;
10642     fab_out.fab$b_fns = 0;
10643     nam_out.naml$l_long_filename = vmsout;
10644     nam_out.naml$l_long_filename_size = strlen(vmsout);
10645     fab_out.fab$l_dna = (char *) -1;
10646     fab_out.fab$b_dns = 0;
10647     nam_out.naml$l_long_defname = nam.naml$l_long_name;
10648     nam_out.naml$l_long_defname_size =
10649         nam.naml$l_long_name ?
10650            nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10651
10652     esa_out = PerlMem_malloc(VMS_MAXRSS);
10653     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
10654     nam_out.naml$l_rsa = NULL;
10655     nam_out.naml$b_rss = 0;
10656     nam_out.naml$l_long_result = NULL;
10657     nam_out.naml$l_long_result_alloc = 0;
10658     nam_out.naml$l_esa = NULL;
10659     nam_out.naml$b_ess = 0;
10660     nam_out.naml$l_long_expand = esa_out;
10661     nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10662
10663     if (preserve_dates == 0) {  /* Act like DCL COPY */
10664       nam_out.naml$b_nop |= NAM$M_SYNCHK;
10665       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10666       if (!((sts = sys$parse(&fab_out)) & 1)) {
10667         PerlMem_free(vmsin);
10668         PerlMem_free(vmsout);
10669         PerlMem_free(esa);
10670         PerlMem_free(rsa);
10671         PerlMem_free(esa_out);
10672         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10673         set_vaxc_errno(sts);
10674         return 0;
10675       }
10676       fab_out.fab$l_xab = (void *) &xabdat;
10677       if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10678     }
10679     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10680       preserve_dates =0;      /* bitmask from this point forward   */
10681
10682     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10683     if (!((sts = sys$create(&fab_out)) & 1)) {
10684       PerlMem_free(vmsin);
10685       PerlMem_free(vmsout);
10686       PerlMem_free(esa);
10687       PerlMem_free(rsa);
10688       PerlMem_free(esa_out);
10689       set_vaxc_errno(sts);
10690       switch (sts) {
10691         case RMS$_DNF:
10692           set_errno(ENOENT); break;
10693         case RMS$_DIR:
10694           set_errno(ENOTDIR); break;
10695         case RMS$_DEV:
10696           set_errno(ENODEV); break;
10697         case RMS$_SYN:
10698           set_errno(EINVAL); break;
10699         case RMS$_PRV:
10700           set_errno(EACCES); break;
10701         default:
10702           set_errno(EVMSERR);
10703       }
10704       return 0;
10705     }
10706     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10707     if (preserve_dates & 2) {
10708       /* sys$close() will process xabrdt, not xabdat */
10709       xabrdt = cc$rms_xabrdt;
10710 #ifndef __GNUC__
10711       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10712 #else
10713       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10714        * is unsigned long[2], while DECC & VAXC use a struct */
10715       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10716 #endif
10717       fab_out.fab$l_xab = (void *) &xabrdt;
10718     }
10719
10720     ubf = PerlMem_malloc(32256);
10721     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
10722     rab_in = cc$rms_rab;
10723     rab_in.rab$l_fab = &fab_in;
10724     rab_in.rab$l_rop = RAB$M_BIO;
10725     rab_in.rab$l_ubf = ubf;
10726     rab_in.rab$w_usz = 32256;
10727     if (!((sts = sys$connect(&rab_in)) & 1)) {
10728       sys$close(&fab_in); sys$close(&fab_out);
10729       PerlMem_free(vmsin);
10730       PerlMem_free(vmsout);
10731       PerlMem_free(esa);
10732       PerlMem_free(ubf);
10733       PerlMem_free(rsa);
10734       PerlMem_free(esa_out);
10735       set_errno(EVMSERR); set_vaxc_errno(sts);
10736       return 0;
10737     }
10738
10739     rab_out = cc$rms_rab;
10740     rab_out.rab$l_fab = &fab_out;
10741     rab_out.rab$l_rbf = ubf;
10742     if (!((sts = sys$connect(&rab_out)) & 1)) {
10743       sys$close(&fab_in); sys$close(&fab_out);
10744       PerlMem_free(vmsin);
10745       PerlMem_free(vmsout);
10746       PerlMem_free(esa);
10747       PerlMem_free(ubf);
10748       PerlMem_free(rsa);
10749       PerlMem_free(esa_out);
10750       set_errno(EVMSERR); set_vaxc_errno(sts);
10751       return 0;
10752     }
10753
10754     while ((sts = sys$read(&rab_in))) {  /* always true  */
10755       if (sts == RMS$_EOF) break;
10756       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10757       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10758         sys$close(&fab_in); sys$close(&fab_out);
10759         PerlMem_free(vmsin);
10760         PerlMem_free(vmsout);
10761         PerlMem_free(esa);
10762         PerlMem_free(ubf);
10763         PerlMem_free(rsa);
10764         PerlMem_free(esa_out);
10765         set_errno(EVMSERR); set_vaxc_errno(sts);
10766         return 0;
10767       }
10768     }
10769
10770
10771     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10772     sys$close(&fab_in);  sys$close(&fab_out);
10773     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10774     if (!(sts & 1)) {
10775       PerlMem_free(vmsin);
10776       PerlMem_free(vmsout);
10777       PerlMem_free(esa);
10778       PerlMem_free(ubf);
10779       PerlMem_free(rsa);
10780       PerlMem_free(esa_out);
10781       set_errno(EVMSERR); set_vaxc_errno(sts);
10782       return 0;
10783     }
10784
10785     PerlMem_free(vmsin);
10786     PerlMem_free(vmsout);
10787     PerlMem_free(esa);
10788     PerlMem_free(ubf);
10789     PerlMem_free(rsa);
10790     PerlMem_free(esa_out);
10791     return 1;
10792
10793 }  /* end of rmscopy() */
10794 #endif
10795 /*}}}*/
10796
10797
10798 /***  The following glue provides 'hooks' to make some of the routines
10799  * from this file available from Perl.  These routines are sufficiently
10800  * basic, and are required sufficiently early in the build process,
10801  * that's it's nice to have them available to miniperl as well as the
10802  * full Perl, so they're set up here instead of in an extension.  The
10803  * Perl code which handles importation of these names into a given
10804  * package lives in [.VMS]Filespec.pm in @INC.
10805  */
10806
10807 void
10808 rmsexpand_fromperl(pTHX_ CV *cv)
10809 {
10810   dXSARGS;
10811   char *fspec, *defspec = NULL, *rslt;
10812   STRLEN n_a;
10813
10814   if (!items || items > 2)
10815     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10816   fspec = SvPV(ST(0),n_a);
10817   if (!fspec || !*fspec) XSRETURN_UNDEF;
10818   if (items == 2) defspec = SvPV(ST(1),n_a);
10819
10820   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10821   ST(0) = sv_newmortal();
10822   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10823   XSRETURN(1);
10824 }
10825
10826 void
10827 vmsify_fromperl(pTHX_ CV *cv)
10828 {
10829   dXSARGS;
10830   char *vmsified;
10831   STRLEN n_a;
10832
10833   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10834   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10835   ST(0) = sv_newmortal();
10836   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10837   XSRETURN(1);
10838 }
10839
10840 void
10841 unixify_fromperl(pTHX_ CV *cv)
10842 {
10843   dXSARGS;
10844   char *unixified;
10845   STRLEN n_a;
10846
10847   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10848   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10849   ST(0) = sv_newmortal();
10850   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10851   XSRETURN(1);
10852 }
10853
10854 void
10855 fileify_fromperl(pTHX_ CV *cv)
10856 {
10857   dXSARGS;
10858   char *fileified;
10859   STRLEN n_a;
10860
10861   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10862   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10863   ST(0) = sv_newmortal();
10864   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10865   XSRETURN(1);
10866 }
10867
10868 void
10869 pathify_fromperl(pTHX_ CV *cv)
10870 {
10871   dXSARGS;
10872   char *pathified;
10873   STRLEN n_a;
10874
10875   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10876   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10877   ST(0) = sv_newmortal();
10878   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10879   XSRETURN(1);
10880 }
10881
10882 void
10883 vmspath_fromperl(pTHX_ CV *cv)
10884 {
10885   dXSARGS;
10886   char *vmspath;
10887   STRLEN n_a;
10888
10889   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10890   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10891   ST(0) = sv_newmortal();
10892   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10893   XSRETURN(1);
10894 }
10895
10896 void
10897 unixpath_fromperl(pTHX_ CV *cv)
10898 {
10899   dXSARGS;
10900   char *unixpath;
10901   STRLEN n_a;
10902
10903   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10904   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10905   ST(0) = sv_newmortal();
10906   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10907   XSRETURN(1);
10908 }
10909
10910 void
10911 candelete_fromperl(pTHX_ CV *cv)
10912 {
10913   dXSARGS;
10914   char fspec[NAM$C_MAXRSS+1], *fsp;
10915   SV *mysv;
10916   IO *io;
10917   STRLEN n_a;
10918
10919   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10920
10921   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10922   if (SvTYPE(mysv) == SVt_PVGV) {
10923     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10924       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10925       ST(0) = &PL_sv_no;
10926       XSRETURN(1);
10927     }
10928     fsp = fspec;
10929   }
10930   else {
10931     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10932       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10933       ST(0) = &PL_sv_no;
10934       XSRETURN(1);
10935     }
10936   }
10937
10938   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10939   XSRETURN(1);
10940 }
10941
10942 void
10943 rmscopy_fromperl(pTHX_ CV *cv)
10944 {
10945   dXSARGS;
10946   char *inspec, *outspec, *inp, *outp;
10947   int date_flag;
10948   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10949                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10950   unsigned long int sts;
10951   SV *mysv;
10952   IO *io;
10953   STRLEN n_a;
10954
10955   if (items < 2 || items > 3)
10956     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10957
10958   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10959   Newx(inspec, VMS_MAXRSS, char);
10960   if (SvTYPE(mysv) == SVt_PVGV) {
10961     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10962       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10963       ST(0) = &PL_sv_no;
10964       Safefree(inspec);
10965       XSRETURN(1);
10966     }
10967     inp = inspec;
10968   }
10969   else {
10970     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10971       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10972       ST(0) = &PL_sv_no;
10973       Safefree(inspec);
10974       XSRETURN(1);
10975     }
10976   }
10977   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
10978   Newx(outspec, VMS_MAXRSS, char);
10979   if (SvTYPE(mysv) == SVt_PVGV) {
10980     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
10981       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10982       ST(0) = &PL_sv_no;
10983       Safefree(inspec);
10984       Safefree(outspec);
10985       XSRETURN(1);
10986     }
10987     outp = outspec;
10988   }
10989   else {
10990     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
10991       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10992       ST(0) = &PL_sv_no;
10993       Safefree(inspec);
10994       Safefree(outspec);
10995       XSRETURN(1);
10996     }
10997   }
10998   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
10999
11000   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11001   Safefree(inspec);
11002   Safefree(outspec);
11003   XSRETURN(1);
11004 }
11005
11006 /* The mod2fname is limited to shorter filenames by design, so it should
11007  * not be modified to support longer EFS pathnames
11008  */
11009 void
11010 mod2fname(pTHX_ CV *cv)
11011 {
11012   dXSARGS;
11013   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11014        workbuff[NAM$C_MAXRSS*1 + 1];
11015   int total_namelen = 3, counter, num_entries;
11016   /* ODS-5 ups this, but we want to be consistent, so... */
11017   int max_name_len = 39;
11018   AV *in_array = (AV *)SvRV(ST(0));
11019
11020   num_entries = av_len(in_array);
11021
11022   /* All the names start with PL_. */
11023   strcpy(ultimate_name, "PL_");
11024
11025   /* Clean up our working buffer */
11026   Zero(work_name, sizeof(work_name), char);
11027
11028   /* Run through the entries and build up a working name */
11029   for(counter = 0; counter <= num_entries; counter++) {
11030     /* If it's not the first name then tack on a __ */
11031     if (counter) {
11032       strcat(work_name, "__");
11033     }
11034     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11035                            PL_na));
11036   }
11037
11038   /* Check to see if we actually have to bother...*/
11039   if (strlen(work_name) + 3 <= max_name_len) {
11040     strcat(ultimate_name, work_name);
11041   } else {
11042     /* It's too darned big, so we need to go strip. We use the same */
11043     /* algorithm as xsubpp does. First, strip out doubled __ */
11044     char *source, *dest, last;
11045     dest = workbuff;
11046     last = 0;
11047     for (source = work_name; *source; source++) {
11048       if (last == *source && last == '_') {
11049         continue;
11050       }
11051       *dest++ = *source;
11052       last = *source;
11053     }
11054     /* Go put it back */
11055     strcpy(work_name, workbuff);
11056     /* Is it still too big? */
11057     if (strlen(work_name) + 3 > max_name_len) {
11058       /* Strip duplicate letters */
11059       last = 0;
11060       dest = workbuff;
11061       for (source = work_name; *source; source++) {
11062         if (last == toupper(*source)) {
11063         continue;
11064         }
11065         *dest++ = *source;
11066         last = toupper(*source);
11067       }
11068       strcpy(work_name, workbuff);
11069     }
11070
11071     /* Is it *still* too big? */
11072     if (strlen(work_name) + 3 > max_name_len) {
11073       /* Too bad, we truncate */
11074       work_name[max_name_len - 2] = 0;
11075     }
11076     strcat(ultimate_name, work_name);
11077   }
11078
11079   /* Okay, return it */
11080   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11081   XSRETURN(1);
11082 }
11083
11084 void
11085 hushexit_fromperl(pTHX_ CV *cv)
11086 {
11087     dXSARGS;
11088
11089     if (items > 0) {
11090         VMSISH_HUSHED = SvTRUE(ST(0));
11091     }
11092     ST(0) = boolSV(VMSISH_HUSHED);
11093     XSRETURN(1);
11094 }
11095
11096
11097 PerlIO *
11098 Perl_vms_start_glob
11099    (pTHX_ SV *tmpglob,
11100     IO *io)
11101 {
11102     PerlIO *fp;
11103     struct vs_str_st *rslt;
11104     char *vmsspec;
11105     char *rstr;
11106     char *begin, *cp;
11107     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11108     PerlIO *tmpfp;
11109     STRLEN i;
11110     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11111     struct dsc$descriptor_vs rsdsc;
11112     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11113     unsigned long hasver = 0, isunix = 0;
11114     unsigned long int lff_flags = 0;
11115     int rms_sts;
11116
11117 #ifdef VMS_LONGNAME_SUPPORT
11118     lff_flags = LIB$M_FIL_LONG_NAMES;
11119 #endif
11120     /* The Newx macro will not allow me to assign a smaller array
11121      * to the rslt pointer, so we will assign it to the begin char pointer
11122      * and then copy the value into the rslt pointer.
11123      */
11124     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11125     rslt = (struct vs_str_st *)begin;
11126     rslt->length = 0;
11127     rstr = &rslt->str[0];
11128     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11129     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11130     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11131     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11132
11133     Newx(vmsspec, VMS_MAXRSS, char);
11134
11135         /* We could find out if there's an explicit dev/dir or version
11136            by peeking into lib$find_file's internal context at
11137            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11138            but that's unsupported, so I don't want to do it now and
11139            have it bite someone in the future. */
11140         /* Fix-me: vms_split_path() is the only way to do this, the
11141            existing method will fail with many legal EFS or UNIX specifications
11142          */
11143
11144     cp = SvPV(tmpglob,i);
11145
11146     for (; i; i--) {
11147         if (cp[i] == ';') hasver = 1;
11148         if (cp[i] == '.') {
11149             if (sts) hasver = 1;
11150             else sts = 1;
11151         }
11152         if (cp[i] == '/') {
11153             hasdir = isunix = 1;
11154             break;
11155         }
11156         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11157             hasdir = 1;
11158             break;
11159         }
11160     }
11161     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11162         Stat_t st;
11163         int stat_sts;
11164         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11165         if (!stat_sts && S_ISDIR(st.st_mode)) {
11166             wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec);
11167             ok = (wilddsc.dsc$a_pointer != NULL);
11168         }
11169         else {
11170             wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec);
11171             ok = (wilddsc.dsc$a_pointer != NULL);
11172         }
11173         if (ok)
11174             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11175
11176         /* If not extended character set, replace ? with % */
11177         /* With extended character set, ? is a wildcard single character */
11178         if (!decc_efs_case_preserve) {
11179             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11180                 if (*cp == '?') *cp = '%';
11181         }
11182         sts = SS$_NORMAL;
11183         while (ok && $VMS_STATUS_SUCCESS(sts)) {
11184          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11185          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11186
11187             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11188                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
11189             if (!$VMS_STATUS_SUCCESS(sts))
11190                 break;
11191
11192             /* with varying string, 1st word of buffer contains result length */
11193             rstr[rslt->length] = '\0';
11194
11195              /* Find where all the components are */
11196              v_sts = vms_split_path
11197                        (aTHX_ rstr,
11198                         &v_spec,
11199                         &v_len,
11200                         &r_spec,
11201                         &r_len,
11202                         &d_spec,
11203                         &d_len,
11204                         &n_spec,
11205                         &n_len,
11206                         &e_spec,
11207                         &e_len,
11208                         &vs_spec,
11209                         &vs_len);
11210
11211             /* If no version on input, truncate the version on output */
11212             if (!hasver && (vs_len > 0)) {
11213                 *vs_spec = '\0';
11214                 vs_len = 0;
11215
11216                 /* No version & a null extension on UNIX handling */
11217                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
11218                     e_len = 0;
11219                     *e_spec = '\0';
11220                 }
11221             }
11222
11223             if (!decc_efs_case_preserve) {
11224                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
11225             }
11226
11227             if (hasdir) {
11228                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
11229                 begin = rstr;
11230             }
11231             else {
11232                 /* Start with the name */
11233                 begin = n_spec;
11234             }
11235             strcat(begin,"\n");
11236             ok = (PerlIO_puts(tmpfp,begin) != EOF);
11237         }
11238         if (cxt) (void)lib$find_file_end(&cxt);
11239         if (ok && sts != RMS$_NMF &&
11240             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
11241         if (!ok) {
11242             if (!(sts & 1)) {
11243                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
11244             }
11245             PerlIO_close(tmpfp);
11246             fp = NULL;
11247         }
11248         else {
11249             PerlIO_rewind(tmpfp);
11250             IoTYPE(io) = IoTYPE_RDONLY;
11251             IoIFP(io) = fp = tmpfp;
11252             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
11253         }
11254     }
11255     Safefree(vmsspec);
11256     Safefree(rslt);
11257     return fp;
11258 }
11259
11260 #ifdef HAS_SYMLINK
11261 static char *
11262 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
11263
11264 void
11265 vms_realpath_fromperl(pTHX_ CV *cv)
11266 {
11267   dXSARGS;
11268   char *fspec, *rslt_spec, *rslt;
11269   STRLEN n_a;
11270
11271   if (!items || items != 1)
11272     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11273
11274   fspec = SvPV(ST(0),n_a);
11275   if (!fspec || !*fspec) XSRETURN_UNDEF;
11276
11277   Newx(rslt_spec, VMS_MAXRSS + 1, char);
11278   rslt = do_vms_realpath(fspec, rslt_spec);
11279   ST(0) = sv_newmortal();
11280   if (rslt != NULL)
11281     sv_usepvn(ST(0),rslt,strlen(rslt));
11282   else
11283     Safefree(rslt_spec);
11284   XSRETURN(1);
11285 }
11286 #endif
11287
11288 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11289 int do_vms_case_tolerant(void);
11290
11291 void
11292 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11293 {
11294   dXSARGS;
11295   ST(0) = boolSV(do_vms_case_tolerant());
11296   XSRETURN(1);
11297 }
11298 #endif
11299
11300 void
11301 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11302                           struct interp_intern *dst)
11303 {
11304     memcpy(dst,src,sizeof(struct interp_intern));
11305 }
11306
11307 void
11308 Perl_sys_intern_clear(pTHX)
11309 {
11310 }
11311
11312 void
11313 Perl_sys_intern_init(pTHX)
11314 {
11315     unsigned int ix = RAND_MAX;
11316     double x;
11317
11318     VMSISH_HUSHED = 0;
11319
11320     /* fix me later to track running under GNV */
11321     /* this allows some limited testing */
11322     MY_POSIX_EXIT = decc_filename_unix_report;
11323
11324     x = (float)ix;
11325     MY_INV_RAND_MAX = 1./x;
11326 }
11327
11328 void
11329 init_os_extras(void)
11330 {
11331   dTHX;
11332   char* file = __FILE__;
11333   char temp_buff[512];
11334   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
11335     no_translate_barewords = TRUE;
11336   } else {
11337     no_translate_barewords = FALSE;
11338   }
11339
11340   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11341   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11342   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11343   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11344   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11345   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11346   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11347   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11348   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11349   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11350   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11351 #ifdef HAS_SYMLINK
11352   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11353 #endif
11354 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11355   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11356 #endif
11357
11358   store_pipelocs(aTHX);         /* will redo any earlier attempts */
11359
11360   return;
11361 }
11362
11363 #ifdef HAS_SYMLINK
11364
11365 #if __CRTL_VER == 80200000
11366 /* This missed getting in to the DECC SDK for 8.2 */
11367 char *realpath(const char *file_name, char * resolved_name, ...);
11368 #endif
11369
11370 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11371 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11372  * The perl fallback routine to provide realpath() is not as efficient
11373  * on OpenVMS.
11374  */
11375 static char *
11376 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11377 {
11378     return realpath(filespec, outbuf);
11379 }
11380
11381 /*}}}*/
11382 /* External entry points */
11383 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11384 { return do_vms_realpath(filespec, outbuf); }
11385 #else
11386 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11387 { return NULL; }
11388 #endif
11389
11390
11391 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11392 /* case_tolerant */
11393
11394 /*{{{int do_vms_case_tolerant(void)*/
11395 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11396  * controlled by a process setting.
11397  */
11398 int do_vms_case_tolerant(void)
11399 {
11400     return vms_process_case_tolerant;
11401 }
11402 /*}}}*/
11403 /* External entry points */
11404 int Perl_vms_case_tolerant(void)
11405 { return do_vms_case_tolerant(); }
11406 #else
11407 int Perl_vms_case_tolerant(void)
11408 { return vms_process_case_tolerant; }
11409 #endif
11410
11411
11412  /* Start of DECC RTL Feature handling */
11413
11414 static int sys_trnlnm
11415    (const char * logname,
11416     char * value,
11417     int value_len)
11418 {
11419     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11420     const unsigned long attr = LNM$M_CASE_BLIND;
11421     struct dsc$descriptor_s name_dsc;
11422     int status;
11423     unsigned short result;
11424     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11425                                 {0, 0, 0, 0}};
11426
11427     name_dsc.dsc$w_length = strlen(logname);
11428     name_dsc.dsc$a_pointer = (char *)logname;
11429     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11430     name_dsc.dsc$b_class = DSC$K_CLASS_S;
11431
11432     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11433
11434     if ($VMS_STATUS_SUCCESS(status)) {
11435
11436          /* Null terminate and return the string */
11437         /*--------------------------------------*/
11438         value[result] = 0;
11439     }
11440
11441     return status;
11442 }
11443
11444 static int sys_crelnm
11445    (const char * logname,
11446     const char * value)
11447 {
11448     int ret_val;
11449     const char * proc_table = "LNM$PROCESS_TABLE";
11450     struct dsc$descriptor_s proc_table_dsc;
11451     struct dsc$descriptor_s logname_dsc;
11452     struct itmlst_3 item_list[2];
11453
11454     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11455     proc_table_dsc.dsc$w_length = strlen(proc_table);
11456     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11457     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11458
11459     logname_dsc.dsc$a_pointer = (char *) logname;
11460     logname_dsc.dsc$w_length = strlen(logname);
11461     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11462     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11463
11464     item_list[0].buflen = strlen(value);
11465     item_list[0].itmcode = LNM$_STRING;
11466     item_list[0].bufadr = (char *)value;
11467     item_list[0].retlen = NULL;
11468
11469     item_list[1].buflen = 0;
11470     item_list[1].itmcode = 0;
11471
11472     ret_val = sys$crelnm
11473                        (NULL,
11474                         (const struct dsc$descriptor_s *)&proc_table_dsc,
11475                         (const struct dsc$descriptor_s *)&logname_dsc,
11476                         NULL,
11477                         (const struct item_list_3 *) item_list);
11478
11479     return ret_val;
11480 }
11481
11482
11483 /* C RTL Feature settings */
11484
11485 static int set_features
11486    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
11487     int (* cli_routine)(void),  /* Not documented */
11488     void *image_info)           /* Not documented */
11489 {
11490     int status;
11491     int s;
11492     int dflt;
11493     char* str;
11494     char val_str[10];
11495 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11496     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
11497     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
11498     unsigned long case_perm;
11499     unsigned long case_image;
11500 #endif
11501
11502     /* Allow an exception to bring Perl into the VMS debugger */
11503     vms_debug_on_exception = 0;
11504     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
11505     if ($VMS_STATUS_SUCCESS(status)) {
11506        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11507          vms_debug_on_exception = 1;
11508        else
11509          vms_debug_on_exception = 0;
11510     }
11511
11512
11513     /* hacks to see if known bugs are still present for testing */
11514
11515     /* Readdir is returning filenames in VMS syntax always */
11516     decc_bug_readdir_efs1 = 1;
11517     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
11518     if ($VMS_STATUS_SUCCESS(status)) {
11519        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11520          decc_bug_readdir_efs1 = 1;
11521        else
11522          decc_bug_readdir_efs1 = 0;
11523     }
11524
11525     /* PCP mode requires creating /dev/null special device file */
11526     decc_bug_devnull = 1;
11527     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
11528     if ($VMS_STATUS_SUCCESS(status)) {
11529        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11530           decc_bug_devnull = 1;
11531        else
11532           decc_bug_devnull = 0;
11533     }
11534
11535     /* fgetname returning a VMS name in UNIX mode */
11536     decc_bug_fgetname = 1;
11537     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
11538     if ($VMS_STATUS_SUCCESS(status)) {
11539       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11540         decc_bug_fgetname = 1;
11541       else
11542         decc_bug_fgetname = 0;
11543     }
11544
11545     /* UNIX directory names with no paths are broken in a lot of places */
11546     decc_dir_barename = 1;
11547     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
11548     if ($VMS_STATUS_SUCCESS(status)) {
11549       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11550         decc_dir_barename = 1;
11551       else
11552         decc_dir_barename = 0;
11553     }
11554
11555 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11556     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
11557     if (s >= 0) {
11558         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
11559         if (decc_disable_to_vms_logname_translation < 0)
11560             decc_disable_to_vms_logname_translation = 0;
11561     }
11562
11563     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
11564     if (s >= 0) {
11565         decc_efs_case_preserve = decc$feature_get_value(s, 1);
11566         if (decc_efs_case_preserve < 0)
11567             decc_efs_case_preserve = 0;
11568     }
11569
11570     s = decc$feature_get_index("DECC$EFS_CHARSET");
11571     if (s >= 0) {
11572         decc_efs_charset = decc$feature_get_value(s, 1);
11573         if (decc_efs_charset < 0)
11574             decc_efs_charset = 0;
11575     }
11576
11577     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
11578     if (s >= 0) {
11579         decc_filename_unix_report = decc$feature_get_value(s, 1);
11580         if (decc_filename_unix_report > 0)
11581             decc_filename_unix_report = 1;
11582         else
11583             decc_filename_unix_report = 0;
11584     }
11585
11586     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
11587     if (s >= 0) {
11588         decc_filename_unix_only = decc$feature_get_value(s, 1);
11589         if (decc_filename_unix_only > 0) {
11590             decc_filename_unix_only = 1;
11591         }
11592         else {
11593             decc_filename_unix_only = 0;
11594         }
11595     }
11596
11597     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
11598     if (s >= 0) {
11599         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
11600         if (decc_filename_unix_no_version < 0)
11601             decc_filename_unix_no_version = 0;
11602     }
11603
11604     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
11605     if (s >= 0) {
11606         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
11607         if (decc_readdir_dropdotnotype < 0)
11608             decc_readdir_dropdotnotype = 0;
11609     }
11610
11611     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
11612     if ($VMS_STATUS_SUCCESS(status)) {
11613         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
11614         if (s >= 0) {
11615             dflt = decc$feature_get_value(s, 4);
11616             if (dflt > 0) {
11617                 decc_disable_posix_root = decc$feature_get_value(s, 1);
11618                 if (decc_disable_posix_root <= 0) {
11619                     decc$feature_set_value(s, 1, 1);
11620                     decc_disable_posix_root = 1;
11621                 }
11622             }
11623             else {
11624                 /* Traditionally Perl assumes this is off */
11625                 decc_disable_posix_root = 1;
11626                 decc$feature_set_value(s, 1, 1);
11627             }
11628         }
11629     }
11630
11631 #if __CRTL_VER >= 80200000
11632     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
11633     if (s >= 0) {
11634         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11635         if (decc_posix_compliant_pathnames < 0)
11636             decc_posix_compliant_pathnames = 0;
11637         if (decc_posix_compliant_pathnames > 4)
11638             decc_posix_compliant_pathnames = 0;
11639     }
11640
11641 #endif
11642 #else
11643     status = sys_trnlnm
11644         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11645     if ($VMS_STATUS_SUCCESS(status)) {
11646         val_str[0] = _toupper(val_str[0]);
11647         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11648            decc_disable_to_vms_logname_translation = 1;
11649         }
11650     }
11651
11652 #ifndef __VAX
11653     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11654     if ($VMS_STATUS_SUCCESS(status)) {
11655         val_str[0] = _toupper(val_str[0]);
11656         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11657            decc_efs_case_preserve = 1;
11658         }
11659     }
11660 #endif
11661
11662     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11663     if ($VMS_STATUS_SUCCESS(status)) {
11664         val_str[0] = _toupper(val_str[0]);
11665         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11666            decc_filename_unix_report = 1;
11667         }
11668     }
11669     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11670     if ($VMS_STATUS_SUCCESS(status)) {
11671         val_str[0] = _toupper(val_str[0]);
11672         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11673            decc_filename_unix_only = 1;
11674            decc_filename_unix_report = 1;
11675         }
11676     }
11677     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11678     if ($VMS_STATUS_SUCCESS(status)) {
11679         val_str[0] = _toupper(val_str[0]);
11680         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11681            decc_filename_unix_no_version = 1;
11682         }
11683     }
11684     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11685     if ($VMS_STATUS_SUCCESS(status)) {
11686         val_str[0] = _toupper(val_str[0]);
11687         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11688            decc_readdir_dropdotnotype = 1;
11689         }
11690     }
11691 #endif
11692
11693 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11694
11695      /* Report true case tolerance */
11696     /*----------------------------*/
11697     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11698     if (!$VMS_STATUS_SUCCESS(status))
11699         case_perm = PPROP$K_CASE_BLIND;
11700     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11701     if (!$VMS_STATUS_SUCCESS(status))
11702         case_image = PPROP$K_CASE_BLIND;
11703     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11704         (case_image == PPROP$K_CASE_SENSITIVE))
11705         vms_process_case_tolerant = 0;
11706
11707 #endif
11708
11709
11710     /* CRTL can be initialized past this point, but not before. */
11711 /*    DECC$CRTL_INIT(); */
11712
11713     return SS$_NORMAL;
11714 }
11715
11716 #ifdef __DECC
11717 /* DECC dependent attributes */
11718 #if __DECC_VER < 60560002
11719 #define relative
11720 #define not_executable
11721 #else
11722 #define relative ,rel
11723 #define not_executable ,noexe
11724 #endif
11725 #pragma nostandard
11726 #pragma extern_model save
11727 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11728 #endif
11729         const __align (LONGWORD) int spare[8] = {0};
11730 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11731 /*                        NOWRT, LONG */
11732 #ifdef __DECC
11733 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11734         nowrt,noshr relative not_executable
11735 #endif
11736 const long vms_cc_features = (const long)set_features;
11737
11738 /*
11739 ** Force a reference to LIB$INITIALIZE to ensure it
11740 ** exists in the image.
11741 */
11742 int lib$initialize(void);
11743 #ifdef __DECC
11744 #pragma extern_model strict_refdef
11745 #endif
11746     int lib_init_ref = (int) lib$initialize;
11747
11748 #ifdef __DECC
11749 #pragma extern_model restore
11750 #pragma standard
11751 #endif
11752
11753 /*  End of vms.c */