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 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  52 int   decc$feature_get_index(const char *name);
  53 char* decc$feature_get_name(int index);
  54 int   decc$feature_get_value(int index, int mode);
  55 int   decc$feature_set_value(int index, int mode, int value);
  56 #else
  57 #include <unixlib.h>
  58 #endif
  59
  60 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  61
  62 static int set_feature_default(const char *name, int value)
  63 {
  64     int status;
  65     int index;
  66
  67     index = decc$feature_get_index(name);
  68
  69     status = decc$feature_set_value(index, 1, value);
  70     if (index == -1 || (status == -1)) {
  71       return -1;
  72     }
  73
  74     status = decc$feature_get_value(index, 1);
  75     if (status != value) {
  76       return -1;
  77     }
  78
  79 return 0;
  80 }
  81 #endif
  82
  83 /* Older versions of ssdef.h don't have these */
  84 #ifndef SS$_INVFILFOROP
  85 #  define SS$_INVFILFOROP 3930
  86 #endif
  87 #ifndef SS$_NOSUCHOBJECT
  88 #  define SS$_NOSUCHOBJECT 2696
  89 #endif
  90
  91 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
  92 #define PERLIO_NOT_STDIO 0
  93
  94 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
  95  * code below needs to get to the underlying CRTL routines. */
  96 #define DONT_MASK_RTL_CALLS
  97 #include "EXTERN.h"
  98 #include "perl.h"
  99 #include "XSUB.h"
 100 /* Anticipating future expansion in lexical warnings . . . */
 101 #ifndef WARN_INTERNAL
 102 #  define WARN_INTERNAL WARN_MISC
 103 #endif
 104
 105 #ifdef VMS_LONGNAME_SUPPORT
 106 #include <libfildef.h>
 107 #endif
 108
 109 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 110 #  define RTL_USES_UTC 1
 111 #endif
 112
 113
 114 /* gcc's header files don't #define direct access macros
 115  * corresponding to VAXC's variant structs */
 116 #ifdef __GNUC__
 117 #  define uic$v_format uic$r_uic_form.uic$v_format
 118 #  define uic$v_group uic$r_uic_form.uic$v_group
 119 #  define uic$v_member uic$r_uic_form.uic$v_member
 120 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 121 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 122 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 123 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 124 #endif
 125
 126 #if defined(NEED_AN_H_ERRNO)
 127 dEXT int h_errno;
 128 #endif
 129
 130 #ifdef __DECC
 131 #pragma message disable pragma
 132 #pragma member_alignment save
 133 #pragma nomember_alignment longword
 134 #pragma message save
 135 #pragma message disable misalgndmem
 136 #endif
 137 struct itmlst_3 {
 138   unsigned short int buflen;
 139   unsigned short int itmcode;
 140   void *bufadr;
 141   unsigned short int *retlen;
 142 };
 143
 144 struct filescan_itmlst_2 {
 145     unsigned short length;
 146     unsigned short itmcode;
 147     char * component;
 148 };
 149
 150 struct vs_str_st {
 151     unsigned short length;
 152     char str[65536];
 153 };
 154
 155 #ifdef __DECC
 156 #pragma message restore
 157 #pragma member_alignment restore
 158 #endif
 159
 160 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
 161 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
 162 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
 163 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
 164 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
 165 #define do_vms_realpath(a,b)            mp_do_vms_realpath(aTHX_ a,b)
 166 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
 167 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
 168 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 169 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 170 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 171
 172 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
 173 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
 174 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
 175 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
 176
 177 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 178 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 179
 180 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 181  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 182  * the Perl facility.
 183  */
 184 #define PERL_LNM_MAX_ITER 10
 185
 186   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 187 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 188 #define MAX_DCL_SYMBOL          (8192)
 189 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 190 #else
 191 #define MAX_DCL_SYMBOL          (1024)
 192 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 193 #endif
 194
 195 static char *__mystrtolower(char *str)
 196 {
 197   if (str) for (; *str; ++str) *str= tolower(*str);
 198   return str;
 199 }
 200
 201 static struct dsc$descriptor_s fildevdsc =
 202   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 203 static struct dsc$descriptor_s crtlenvdsc =
 204   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 205 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 206 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 207 static struct dsc$descriptor_s **env_tables = defenv;
 208 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 209
 210 /* True if we shouldn't treat barewords as logicals during directory */
 211 /* munching */
 212 static int no_translate_barewords;
 213
 214 #ifndef RTL_USES_UTC
 215 static int tz_updated = 1;
 216 #endif
 217
 218 /* DECC Features that may need to affect how Perl interprets
 219  * displays filename information
 220  */
 221 static int decc_disable_to_vms_logname_translation = 1;
 222 static int decc_disable_posix_root = 1;
 223 int decc_efs_case_preserve = 0;
 224 static int decc_efs_charset = 0;
 225 static int decc_filename_unix_no_version = 0;
 226 static int decc_filename_unix_only = 0;
 227 int decc_filename_unix_report = 0;
 228 int decc_posix_compliant_pathnames = 0;
 229 int decc_readdir_dropdotnotype = 0;
 230 static int vms_process_case_tolerant = 1;
 231
 232 /* bug workarounds if needed */
 233 int decc_bug_readdir_efs1 = 0;
 234 int decc_bug_devnull = 1;
 235 int decc_bug_fgetname = 0;
 236 int decc_dir_barename = 0;
 237
 238 static int vms_debug_on_exception = 0;
 239
 240 /* Is this a UNIX file specification?
 241  *   No longer a simple check with EFS file specs
 242  *   For now, not a full check, but need to
 243  *   handle POSIX ^UP^ specifications
 244  *   Fixing to handle ^/ cases would require
 245  *   changes to many other conversion routines.
 246  */
 247
 248 static int is_unix_filespec(const char *path)
 249 {
 250 int ret_val;
 251 const char * pch1;
 252
 253     ret_val = 0;
 254     if (strncmp(path,"\"^UP^",5) != 0) {
 255         pch1 = strchr(path, '/');
 256         if (pch1 != NULL)
 257             ret_val = 1;
 258         else {
 259
 260             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 261             if (decc_filename_unix_report || decc_filename_unix_only) {
 262             if (strcmp(path,".") == 0)
 263                 ret_val = 1;
 264             }
 265         }
 266     }
 267     return ret_val;
 268 }
 269
 270 /* This handles the expansion of a '^' prefix to the proper character
 271  * in a UNIX file specification.
 272  *
 273  * The output count variable contains the number of characters added
 274  * to the output string.
 275  *
 276  * The return value is the number of characters read from the input
 277  * string
 278  */
 279 static int copy_expand_vms_filename_escape
 280   (char *outspec, const char *inspec, int *output_cnt)
 281 {
 282 int count;
 283 int scnt;
 284
 285     count = 0;
 286     *output_cnt = 0;
 287     if (*inspec == '^') {
 288         inspec++;
 289         switch (*inspec) {
 290         case '.':
 291             /* Non trailing dots should just be passed through */
 292             *outspec = *inspec;
 293             count++;
 294             (*output_cnt)++;
 295             break;
 296         case '_': /* space */
 297             *outspec = ' ';
 298             inspec++;
 299             count++;
 300             (*output_cnt)++;
 301             break;
 302         case 'U': /* Unicode */
 303             inspec++;
 304             count++;
 305             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 306             if (scnt == 4) {
 307                 unsigned int c1, c2;
 308                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 309                 outspec[0] == c1 & 0xff;
 310                 outspec[1] == c2 & 0xff;
 311                 if (scnt > 1) {
 312                     (*output_cnt) += 2;
 313                     count += 4;
 314                 }
 315             }
 316             else {
 317                 /* Error - do best we can to continue */
 318                 *outspec = 'U';
 319                 outspec++;
 320                 (*output_cnt++);
 321                 *outspec = *inspec;
 322                 count++;
 323                 (*output_cnt++);
 324             }
 325             break;
 326         default:
 327             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 328             if (scnt == 2) {
 329                 /* Hex encoded */
 330                 unsigned int c1;
 331                 scnt = sscanf(inspec, "%2x", &c1);
 332                 outspec[0] = c1 & 0xff;
 333                 if (scnt > 0) {
 334                     (*output_cnt++);
 335                     count += 2;
 336                 }
 337             }
 338             else {
 339                 *outspec = *inspec;
 340                 count++;
 341                 (*output_cnt++);
 342             }
 343         }
 344     }
 345     else {
 346         *outspec = *inspec;
 347         count++;
 348         (*output_cnt)++;
 349     }
 350     return count;
 351 }
 352
 353
 354 int SYS$FILESCAN
 355    (const struct dsc$descriptor_s * srcstr,
 356     struct filescan_itmlst_2 * valuelist,
 357     unsigned long * fldflags,
 358     struct dsc$descriptor_s *auxout,
 359     unsigned short * retlen);
 360
 361 /* vms_split_path - Verify that the input file specification is a
 362  * VMS format file specification, and provide pointers to the components of
 363  * it.  With EFS format filenames, this is virtually the only way to
 364  * parse a VMS path specification into components.
 365  *
 366  * If the sum of the components do not add up to the length of the
 367  * string, then the passed file specification is probably a UNIX style
 368  * path.
 369  */
 370 static int vms_split_path
 371    (pTHX_ const char * path,
 372     char * * volume,
 373     int * vol_len,
 374     char * * root,
 375     int * root_len,
 376     char * * dir,
 377     int * dir_len,
 378     char * * name,
 379     int * name_len,
 380     char * * ext,
 381     int * ext_len,
 382     char * * version,
 383     int * ver_len)
 384 {
 385 struct dsc$descriptor path_desc;
 386 int status;
 387 unsigned long flags;
 388 int ret_stat;
 389 struct filescan_itmlst_2 item_list[9];
 390 const int filespec = 0;
 391 const int nodespec = 1;
 392 const int devspec = 2;
 393 const int rootspec = 3;
 394 const int dirspec = 4;
 395 const int namespec = 5;
 396 const int typespec = 6;
 397 const int verspec = 7;
 398
 399     /* Assume the worst for an easy exit */
 400     ret_stat = -1;
 401     *volume = NULL;
 402     *vol_len = 0;
 403     *root = NULL;
 404     *root_len = 0;
 405     *dir = NULL;
 406     *dir_len;
 407     *name = NULL;
 408     *name_len = 0;
 409     *ext = NULL;
 410     *ext_len = 0;
 411     *version = NULL;
 412     *ver_len = 0;
 413
 414     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 415     path_desc.dsc$w_length = strlen(path);
 416     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 417     path_desc.dsc$b_class = DSC$K_CLASS_S;
 418
 419     /* Get the total length, if it is shorter than the string passed
 420      * then this was probably not a VMS formatted file specification
 421      */
 422     item_list[filespec].itmcode = FSCN$_FILESPEC;
 423     item_list[filespec].length = 0;
 424     item_list[filespec].component = NULL;
 425
 426     /* If the node is present, then it gets considered as part of the
 427      * volume name to hopefully make things simple.
 428      */
 429     item_list[nodespec].itmcode = FSCN$_NODE;
 430     item_list[nodespec].length = 0;
 431     item_list[nodespec].component = NULL;
 432
 433     item_list[devspec].itmcode = FSCN$_DEVICE;
 434     item_list[devspec].length = 0;
 435     item_list[devspec].component = NULL;
 436
 437     /* root is a special case,  adding it to either the directory or
 438      * the device components will probalby complicate things for the
 439      * callers of this routine, so leave it separate.
 440      */
 441     item_list[rootspec].itmcode = FSCN$_ROOT;
 442     item_list[rootspec].length = 0;
 443     item_list[rootspec].component = NULL;
 444
 445     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 446     item_list[dirspec].length = 0;
 447     item_list[dirspec].component = NULL;
 448
 449     item_list[namespec].itmcode = FSCN$_NAME;
 450     item_list[namespec].length = 0;
 451     item_list[namespec].component = NULL;
 452
 453     item_list[typespec].itmcode = FSCN$_TYPE;
 454     item_list[typespec].length = 0;
 455     item_list[typespec].component = NULL;
 456
 457     item_list[verspec].itmcode = FSCN$_VERSION;
 458     item_list[verspec].length = 0;
 459     item_list[verspec].component = NULL;
 460
 461     item_list[8].itmcode = 0;
 462     item_list[8].length = 0;
 463     item_list[8].component = NULL;
 464
 465     status = SYS$FILESCAN
 466        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 467         &flags, NULL, NULL);
 468     _ckvmssts(status); /* All failure status values indicate a coding error */
 469
 470     /* If we parsed it successfully these two lengths should be the same */
 471     if (path_desc.dsc$w_length != item_list[filespec].length)
 472         return ret_stat;
 473
 474     /* If we got here, then it is a VMS file specification */
 475     ret_stat = 0;
 476
 477     /* set the volume name */
 478     if (item_list[nodespec].length > 0) {
 479         *volume = item_list[nodespec].component;
 480         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 481     }
 482     else {
 483         *volume = item_list[devspec].component;
 484         *vol_len = item_list[devspec].length;
 485     }
 486
 487     *root = item_list[rootspec].component;
 488     *root_len = item_list[rootspec].length;
 489
 490     *dir = item_list[dirspec].component;
 491     *dir_len = item_list[dirspec].length;
 492
 493     /* Now fun with versions and EFS file specifications
 494      * The parser can not tell the difference when a "." is a version
 495      * delimiter or a part of the file specification.
 496      */
 497     if ((decc_efs_charset) &&
 498         (item_list[verspec].length > 0) &&
 499         (item_list[verspec].component[0] == '.')) {
 500         *name = item_list[namespec].component;
 501         *name_len = item_list[namespec].length + item_list[typespec].length;
 502         *ext = item_list[verspec].component;
 503         *ext_len = item_list[verspec].length;
 504         *version = NULL;
 505         *ver_len = 0;
 506     }
 507     else {
 508         *name = item_list[namespec].component;
 509         *name_len = item_list[namespec].length;
 510         *ext = item_list[typespec].component;
 511         *ext_len = item_list[typespec].length;
 512         *version = item_list[verspec].component;
 513         *ver_len = item_list[verspec].length;
 514     }
 515     return ret_stat;
 516 }
 517
 518
 519 /* my_maxidx
 520  * Routine to retrieve the maximum equivalence index for an input
 521  * logical name.  Some calls to this routine have no knowledge if
 522  * the variable is a logical or not.  So on error we return a max
 523  * index of zero.
 524  */
 525 /*{{{int my_maxidx(const char *lnm) */
 526 static int
 527 my_maxidx(const char *lnm)
 528 {
 529     int status;
 530     int midx;
 531     int attr = LNM$M_CASE_BLIND;
 532     struct dsc$descriptor lnmdsc;
 533     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 534                                 {0, 0, 0, 0}};
 535
 536     lnmdsc.dsc$w_length = strlen(lnm);
 537     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 538     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 539     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 540
 541     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 542     if ((status & 1) == 0)
 543        midx = 0;
 544
 545     return (midx);
 546 }
 547 /*}}}*/
 548
 549 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 550 int
 551 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 552   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 553 {
 554     const char *cp1;
 555     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 556     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 557     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 558     int midx;
 559     unsigned char acmode;
 560     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 561                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 562     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 563                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 564                                  {0, 0, 0, 0}};
 565     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 566 #if defined(PERL_IMPLICIT_CONTEXT)
 567     pTHX = NULL;
 568     if (PL_curinterp) {
 569       aTHX = PERL_GET_INTERP;
 570     } else {
 571       aTHX = NULL;
 572     }
 573 #endif
 574
 575     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 576       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 577     }
 578     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 579       *cp2 = _toupper(*cp1);
 580       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 581         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 582         return 0;
 583       }
 584     }
 585     lnmdsc.dsc$w_length = cp1 - lnm;
 586     lnmdsc.dsc$a_pointer = uplnm;
 587     uplnm[lnmdsc.dsc$w_length] = '\0';
 588     secure = flags & PERL__TRNENV_SECURE;
 589     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 590     if (!tabvec || !*tabvec) tabvec = env_tables;
 591
 592     for (curtab = 0; tabvec[curtab]; curtab++) {
 593       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 594         if (!ivenv && !secure) {
 595           char *eq, *end;
 596           int i;
 597           if (!environ) {
 598             ivenv = 1;
 599             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 600             continue;
 601           }
 602           retsts = SS$_NOLOGNAM;
 603           for (i = 0; environ[i]; i++) {
 604             if ((eq = strchr(environ[i],'=')) &&
 605                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 606                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 607               eq++;
 608               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 609               if (!eqvlen) continue;
 610               retsts = SS$_NORMAL;
 611               break;
 612             }
 613           }
 614           if (retsts != SS$_NOLOGNAM) break;
 615         }
 616       }
 617       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 618                !str$case_blind_compare(&tmpdsc,&clisym)) {
 619         if (!ivsym && !secure) {
 620           unsigned short int deflen = LNM$C_NAMLENGTH;
 621           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 622           /* dynamic dsc to accomodate possible long value */
 623           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 624           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 625           if (retsts & 1) {
 626             if (eqvlen > MAX_DCL_SYMBOL) {
 627               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 628               eqvlen = MAX_DCL_SYMBOL;
 629               /* Special hack--we might be called before the interpreter's */
 630               /* fully initialized, in which case either thr or PL_curcop */
 631               /* might be bogus. We have to check, since ckWARN needs them */
 632               /* both to be valid if running threaded */
 633                 if (ckWARN(WARN_MISC)) {
 634                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 635                 }
 636             }
 637             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 638           }
 639           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 640           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 641           if (retsts == LIB$_NOSUCHSYM) continue;
 642           break;
 643         }
 644       }
 645       else if (!ivlnm) {
 646         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 647           midx = my_maxidx(lnm);
 648           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 649             lnmlst[1].bufadr = cp2;
 650             eqvlen = 0;
 651             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 652             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 653             if (retsts == SS$_NOLOGNAM) break;
 654             /* PPFs have a prefix */
 655             if (
 656 #if INTSIZE == 4
 657                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 658 #endif
 659                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 660                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 661                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 662                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 663                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 664               memmove(eqv,eqv+4,eqvlen-4);
 665               eqvlen -= 4;
 666             }
 667             cp2 += eqvlen;
 668             *cp2 = '\0';
 669           }
 670           if ((retsts == SS$_IVLOGNAM) ||
 671               (retsts == SS$_NOLOGNAM)) { continue; }
 672         }
 673         else {
 674           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 675           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 676           if (retsts == SS$_NOLOGNAM) continue;
 677           eqv[eqvlen] = '\0';
 678         }
 679         eqvlen = strlen(eqv);
 680         break;
 681       }
 682     }
 683     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 684     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 685              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 686              retsts == SS$_NOLOGNAM) {
 687       set_errno(EINVAL);  set_vaxc_errno(retsts);
 688     }
 689     else _ckvmssts(retsts);
 690     return 0;
 691 }  /* end of vmstrnenv */
 692 /*}}}*/
 693
 694 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 695 /* Define as a function so we can access statics. */
 696 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 697 {
 698   return vmstrnenv(lnm,eqv,idx,fildev,
 699 #ifdef SECURE_INTERNAL_GETENV
 700                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 701 #else
 702                    0
 703 #endif
 704                                                                               );
 705 }
 706 /*}}}*/
 707
 708 /* my_getenv
 709  * Note: Uses Perl temp to store result so char * can be returned to
 710  * caller; this pointer will be invalidated at next Perl statement
 711  * transition.
 712  * We define this as a function rather than a macro in terms of my_getenv_len()
 713  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 714  * allocate SVs).
 715  */
 716 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 717 char *
 718 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 719 {
 720     const char *cp1;
 721     static char *__my_getenv_eqv = NULL;
 722     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 723     unsigned long int idx = 0;
 724     int trnsuccess, success, secure, saverr, savvmserr;
 725     int midx, flags;
 726     SV *tmpsv;
 727
 728     midx = my_maxidx(lnm) + 1;
 729
 730     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 731       /* Set up a temporary buffer for the return value; Perl will
 732        * clean it up at the next statement transition */
 733       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 734       if (!tmpsv) return NULL;
 735       eqv = SvPVX(tmpsv);
 736     }
 737     else {
 738       /* Assume no interpreter ==> single thread */
 739       if (__my_getenv_eqv != NULL) {
 740         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 741       }
 742       else {
 743         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 744       }
 745       eqv = __my_getenv_eqv;
 746     }
 747
 748     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 749     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 750       int len;
 751       getcwd(eqv,LNM$C_NAMLENGTH);
 752
 753       len = strlen(eqv);
 754
 755       /* Get rid of "000000/ in rooted filespecs */
 756       if (len > 7) {
 757         char * zeros;
 758         zeros = strstr(eqv, "/000000/");
 759         if (zeros != NULL) {
 760           int mlen;
 761           mlen = len - (zeros - eqv) - 7;
 762           memmove(zeros, &zeros[7], mlen);
 763           len = len - 7;
 764           eqv[len] = '\0';
 765         }
 766       }
 767       return eqv;
 768     }
 769     else {
 770       /* Impose security constraints only if tainting */
 771       if (sys) {
 772         /* Impose security constraints only if tainting */
 773         secure = PL_curinterp ? PL_tainting : will_taint;
 774         saverr = errno;  savvmserr = vaxc$errno;
 775       }
 776       else {
 777         secure = 0;
 778       }
 779
 780       flags =
 781 #ifdef SECURE_INTERNAL_GETENV
 782               secure ? PERL__TRNENV_SECURE : 0
 783 #else
 784               0
 785 #endif
 786       ;
 787
 788       /* For the getenv interface we combine all the equivalence names
 789        * of a search list logical into one value to acquire a maximum
 790        * value length of 255*128 (assuming %ENV is using logicals).
 791        */
 792       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 793
 794       /* If the name contains a semicolon-delimited index, parse it
 795        * off and make sure we only retrieve the equivalence name for
 796        * that index.  */
 797       if ((cp2 = strchr(lnm,';')) != NULL) {
 798         strcpy(uplnm,lnm);
 799         uplnm[cp2-lnm] = '\0';
 800         idx = strtoul(cp2+1,NULL,0);
 801         lnm = uplnm;
 802         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 803       }
 804
 805       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
 806
 807       /* Discard NOLOGNAM on internal calls since we're often looking
 808        * for an optional name, and this "error" often shows up as the
 809        * (bogus) exit status for a die() call later on.  */
 810       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 811       return success ? eqv : Nullch;
 812     }
 813
 814 }  /* end of my_getenv() */
 815 /*}}}*/
 816
 817
 818 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 819 char *
 820 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 821 {
 822     const char *cp1;
 823     char *buf, *cp2;
 824     unsigned long idx = 0;
 825     int midx, flags;
 826     static char *__my_getenv_len_eqv = NULL;
 827     int secure, saverr, savvmserr;
 828     SV *tmpsv;
 829
 830     midx = my_maxidx(lnm) + 1;
 831
 832     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 833       /* Set up a temporary buffer for the return value; Perl will
 834        * clean it up at the next statement transition */
 835       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 836       if (!tmpsv) return NULL;
 837       buf = SvPVX(tmpsv);
 838     }
 839     else {
 840       /* Assume no interpreter ==> single thread */
 841       if (__my_getenv_len_eqv != NULL) {
 842         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 843       }
 844       else {
 845         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 846       }
 847       buf = __my_getenv_len_eqv;
 848     }
 849
 850     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 851     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 852     char * zeros;
 853
 854       getcwd(buf,LNM$C_NAMLENGTH);
 855       *len = strlen(buf);
 856
 857       /* Get rid of "000000/ in rooted filespecs */
 858       if (*len > 7) {
 859       zeros = strstr(buf, "/000000/");
 860       if (zeros != NULL) {
 861         int mlen;
 862         mlen = *len - (zeros - buf) - 7;
 863         memmove(zeros, &zeros[7], mlen);
 864         *len = *len - 7;
 865         buf[*len] = '\0';
 866         }
 867       }
 868       return buf;
 869     }
 870     else {
 871       if (sys) {
 872         /* Impose security constraints only if tainting */
 873         secure = PL_curinterp ? PL_tainting : will_taint;
 874         saverr = errno;  savvmserr = vaxc$errno;
 875       }
 876       else {
 877         secure = 0;
 878       }
 879
 880       flags =
 881 #ifdef SECURE_INTERNAL_GETENV
 882               secure ? PERL__TRNENV_SECURE : 0
 883 #else
 884               0
 885 #endif
 886       ;
 887
 888       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 889
 890       if ((cp2 = strchr(lnm,';')) != NULL) {
 891         strcpy(buf,lnm);
 892         buf[cp2-lnm] = '\0';
 893         idx = strtoul(cp2+1,NULL,0);
 894         lnm = buf;
 895         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 896       }
 897
 898       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
 899
 900       /* Get rid of "000000/ in rooted filespecs */
 901       if (*len > 7) {
 902       char * zeros;
 903         zeros = strstr(buf, "/000000/");
 904         if (zeros != NULL) {
 905           int mlen;
 906           mlen = *len - (zeros - buf) - 7;
 907           memmove(zeros, &zeros[7], mlen);
 908           *len = *len - 7;
 909           buf[*len] = '\0';
 910         }
 911       }
 912
 913       /* Discard NOLOGNAM on internal calls since we're often looking
 914        * for an optional name, and this "error" often shows up as the
 915        * (bogus) exit status for a die() call later on.  */
 916       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 917       return *len ? buf : Nullch;
 918     }
 919
 920 }  /* end of my_getenv_len() */
 921 /*}}}*/
 922
 923 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 924
 925 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 926
 927 /*{{{ void prime_env_iter() */
 928 void
 929 prime_env_iter(void)
 930 /* Fill the %ENV associative array with all logical names we can
 931  * find, in preparation for iterating over it.
 932  */
 933 {
 934   static int primed = 0;
 935   HV *seenhv = NULL, *envhv;
 936   SV *sv = NULL;
 937   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 938   unsigned short int chan;
 939 #ifndef CLI$M_TRUSTED
 940 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 941 #endif
 942   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 943   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 944   long int i;
 945   bool have_sym = FALSE, have_lnm = FALSE;
 946   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 947   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 948   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 949   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 950   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 951 #if defined(PERL_IMPLICIT_CONTEXT)
 952   pTHX;
 953 #endif
 954 #if defined(USE_ITHREADS)
 955   static perl_mutex primenv_mutex;
 956   MUTEX_INIT(&primenv_mutex);
 957 #endif
 958
 959 #if defined(PERL_IMPLICIT_CONTEXT)
 960     /* We jump through these hoops because we can be called at */
 961     /* platform-specific initialization time, which is before anything is */
 962     /* set up--we can't even do a plain dTHX since that relies on the */
 963     /* interpreter structure to be initialized */
 964     if (PL_curinterp) {
 965       aTHX = PERL_GET_INTERP;
 966     } else {
 967       aTHX = NULL;
 968     }
 969 #endif
 970
 971   if (primed || !PL_envgv) return;
 972   MUTEX_LOCK(&primenv_mutex);
 973   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
 974   envhv = GvHVn(PL_envgv);
 975   /* Perform a dummy fetch as an lval to insure that the hash table is
 976    * set up.  Otherwise, the hv_store() will turn into a nullop. */
 977   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
 978
 979   for (i = 0; env_tables[i]; i++) {
 980      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 981          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
 982      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
 983   }
 984   if (have_sym || have_lnm) {
 985     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 986     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 987     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
 988     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
 989   }
 990
 991   for (i--; i >= 0; i--) {
 992     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
 993       char *start;
 994       int j;
 995       for (j = 0; environ[j]; j++) {
 996         if (!(start = strchr(environ[j],'='))) {
 997           if (ckWARN(WARN_INTERNAL))
 998             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
 999         }
1000         else {
1001           start++;
1002           sv = newSVpv(start,0);
1003           SvTAINTED_on(sv);
1004           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1005         }
1006       }
1007       continue;
1008     }
1009     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1010              !str$case_blind_compare(&tmpdsc,&clisym)) {
1011       strcpy(cmd,"Show Symbol/Global *");
1012       cmddsc.dsc$w_length = 20;
1013       if (env_tables[i]->dsc$w_length == 12 &&
1014           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1015           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1016       flags = defflags | CLI$M_NOLOGNAM;
1017     }
1018     else {
1019       strcpy(cmd,"Show Logical *");
1020       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1021         strcat(cmd," /Table=");
1022         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1023         cmddsc.dsc$w_length = strlen(cmd);
1024       }
1025       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1026       flags = defflags | CLI$M_NOCLISYM;
1027     }
1028
1029     /* Create a new subprocess to execute each command, to exclude the
1030      * remote possibility that someone could subvert a mbx or file used
1031      * to write multiple commands to a single subprocess.
1032      */
1033     do {
1034       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1035                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1036       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1037       defflags &= ~CLI$M_TRUSTED;
1038     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1039     _ckvmssts(retsts);
1040     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1041     if (seenhv) SvREFCNT_dec(seenhv);
1042     seenhv = newHV();
1043     while (1) {
1044       char *cp1, *cp2, *key;
1045       unsigned long int sts, iosb[2], retlen, keylen;
1046       register U32 hash;
1047
1048       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1049       if (sts & 1) sts = iosb[0] & 0xffff;
1050       if (sts == SS$_ENDOFFILE) {
1051         int wakect = 0;
1052         while (substs == 0) { sys$hiber(); wakect++;}
1053         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1054         _ckvmssts(substs);
1055         break;
1056       }
1057       _ckvmssts(sts);
1058       retlen = iosb[0] >> 16;
1059       if (!retlen) continue;  /* blank line */
1060       buf[retlen] = '\0';
1061       if (iosb[1] != subpid) {
1062         if (iosb[1]) {
1063           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1064         }
1065         continue;
1066       }
1067       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1068         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1069
1070       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1071       if (*cp1 == '(' || /* Logical name table name */
1072           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1073       if (*cp1 == '"') cp1++;
1074       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1075       key = cp1;  keylen = cp2 - cp1;
1076       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1077       while (*cp2 && *cp2 != '=') cp2++;
1078       while (*cp2 && *cp2 == '=') cp2++;
1079       while (*cp2 && *cp2 == ' ') cp2++;
1080       if (*cp2 == '"') {  /* String translation; may embed "" */
1081         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1082         cp2++;  cp1--; /* Skip "" surrounding translation */
1083       }
1084       else {  /* Numeric translation */
1085         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1086         cp1--;  /* stop on last non-space char */
1087       }
1088       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1089         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1090         continue;
1091       }
1092       PERL_HASH(hash,key,keylen);
1093
1094       if (cp1 == cp2 && *cp2 == '.') {
1095         /* A single dot usually means an unprintable character, such as a null
1096          * to indicate a zero-length value.  Get the actual value to make sure.
1097          */
1098         char lnm[LNM$C_NAMLENGTH+1];
1099         char eqv[MAX_DCL_SYMBOL+1];
1100         strncpy(lnm, key, keylen);
1101         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1102         sv = newSVpvn(eqv, strlen(eqv));
1103       }
1104       else {
1105         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1106       }
1107
1108       SvTAINTED_on(sv);
1109       hv_store(envhv,key,keylen,sv,hash);
1110       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1111     }
1112     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1113       /* get the PPFs for this process, not the subprocess */
1114       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1115       char eqv[LNM$C_NAMLENGTH+1];
1116       int trnlen, i;
1117       for (i = 0; ppfs[i]; i++) {
1118         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1119         sv = newSVpv(eqv,trnlen);
1120         SvTAINTED_on(sv);
1121         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1122       }
1123     }
1124   }
1125   primed = 1;
1126   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1127   if (buf) Safefree(buf);
1128   if (seenhv) SvREFCNT_dec(seenhv);
1129   MUTEX_UNLOCK(&primenv_mutex);
1130   return;
1131
1132 }  /* end of prime_env_iter */
1133 /*}}}*/
1134
1135
1136 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1137 /* Define or delete an element in the same "environment" as
1138  * vmstrnenv().  If an element is to be deleted, it's removed from
1139  * the first place it's found.  If it's to be set, it's set in the
1140  * place designated by the first element of the table vector.
1141  * Like setenv() returns 0 for success, non-zero on error.
1142  */
1143 int
1144 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1145 {
1146     const char *cp1;
1147     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1148     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1149     int nseg = 0, j;
1150     unsigned long int retsts, usermode = PSL$C_USER;
1151     struct itmlst_3 *ile, *ilist;
1152     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1153                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1154                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1155     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1156     $DESCRIPTOR(local,"_LOCAL");
1157
1158     if (!lnm) {
1159         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1160         return SS$_IVLOGNAM;
1161     }
1162
1163     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1164       *cp2 = _toupper(*cp1);
1165       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1166         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1167         return SS$_IVLOGNAM;
1168       }
1169     }
1170     lnmdsc.dsc$w_length = cp1 - lnm;
1171     if (!tabvec || !*tabvec) tabvec = env_tables;
1172
1173     if (!eqv) {  /* we're deleting n element */
1174       for (curtab = 0; tabvec[curtab]; curtab++) {
1175         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1176         int i;
1177           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1178             if ((cp1 = strchr(environ[i],'=')) &&
1179                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1180                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1181 #ifdef HAS_SETENV
1182               return setenv(lnm,"",1) ? vaxc$errno : 0;
1183             }
1184           }
1185           ivenv = 1; retsts = SS$_NOLOGNAM;
1186 #else
1187               if (ckWARN(WARN_INTERNAL))
1188                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1189               ivenv = 1; retsts = SS$_NOSUCHPGM;
1190               break;
1191             }
1192           }
1193 #endif
1194         }
1195         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1196                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1197           unsigned int symtype;
1198           if (tabvec[curtab]->dsc$w_length == 12 &&
1199               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1200               !str$case_blind_compare(&tmpdsc,&local))
1201             symtype = LIB$K_CLI_LOCAL_SYM;
1202           else symtype = LIB$K_CLI_GLOBAL_SYM;
1203           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1204           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1205           if (retsts == LIB$_NOSUCHSYM) continue;
1206           break;
1207         }
1208         else if (!ivlnm) {
1209           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1210           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1211           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1212           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1213           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1214         }
1215       }
1216     }
1217     else {  /* we're defining a value */
1218       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1219 #ifdef HAS_SETENV
1220         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1221 #else
1222         if (ckWARN(WARN_INTERNAL))
1223           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1224         retsts = SS$_NOSUCHPGM;
1225 #endif
1226       }
1227       else {
1228         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1229         eqvdsc.dsc$w_length  = strlen(eqv);
1230         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1231             !str$case_blind_compare(&tmpdsc,&clisym)) {
1232           unsigned int symtype;
1233           if (tabvec[0]->dsc$w_length == 12 &&
1234               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1235                !str$case_blind_compare(&tmpdsc,&local))
1236             symtype = LIB$K_CLI_LOCAL_SYM;
1237           else symtype = LIB$K_CLI_GLOBAL_SYM;
1238           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1239         }
1240         else {
1241           if (!*eqv) eqvdsc.dsc$w_length = 1;
1242           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1243
1244             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1245             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1246               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1247                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1248               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1249               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1250             }
1251
1252             Newx(ilist,nseg+1,struct itmlst_3);
1253             ile = ilist;
1254             if (!ile) {
1255               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1256               return SS$_INSFMEM;
1257             }
1258             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1259
1260             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1261               ile->itmcode = LNM$_STRING;
1262               ile->bufadr = c;
1263               if ((j+1) == nseg) {
1264                 ile->buflen = strlen(c);
1265                 /* in case we are truncating one that's too long */
1266                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1267               }
1268               else {
1269                 ile->buflen = LNM$C_NAMLENGTH;
1270               }
1271             }
1272
1273             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1274             Safefree (ilist);
1275           }
1276           else {
1277             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1278           }
1279         }
1280       }
1281     }
1282     if (!(retsts & 1)) {
1283       switch (retsts) {
1284         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1285         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1286           set_errno(EVMSERR); break;
1287         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1288         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1289           set_errno(EINVAL); break;
1290         case SS$_NOPRIV:
1291           set_errno(EACCES);
1292         default:
1293           _ckvmssts(retsts);
1294           set_errno(EVMSERR);
1295        }
1296        set_vaxc_errno(retsts);
1297        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1298     }
1299     else {
1300       /* We reset error values on success because Perl does an hv_fetch()
1301        * before each hv_store(), and if the thing we're setting didn't
1302        * previously exist, we've got a leftover error message.  (Of course,
1303        * this fails in the face of
1304        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1305        * in that the error reported in $! isn't spurious,
1306        * but it's right more often than not.)
1307        */
1308       set_errno(0); set_vaxc_errno(retsts);
1309       return 0;
1310     }
1311
1312 }  /* end of vmssetenv() */
1313 /*}}}*/
1314
1315 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1316 /* This has to be a function since there's a prototype for it in proto.h */
1317 void
1318 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1319 {
1320     if (lnm && *lnm) {
1321       int len = strlen(lnm);
1322       if  (len == 7) {
1323         char uplnm[8];
1324         int i;
1325         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1326         if (!strcmp(uplnm,"DEFAULT")) {
1327           if (eqv && *eqv) my_chdir(eqv);
1328           return;
1329         }
1330     }
1331 #ifndef RTL_USES_UTC
1332     if (len == 6 || len == 2) {
1333       char uplnm[7];
1334       int i;
1335       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1336       uplnm[len] = '\0';
1337       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1338       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1339     }
1340 #endif
1341   }
1342   (void) vmssetenv(lnm,eqv,NULL);
1343 }
1344 /*}}}*/
1345
1346 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1347 /*  vmssetuserlnm
1348  *  sets a user-mode logical in the process logical name table
1349  *  used for redirection of sys$error
1350  */
1351 void
1352 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1353 {
1354     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1355     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1356     unsigned long int iss, attr = LNM$M_CONFINE;
1357     unsigned char acmode = PSL$C_USER;
1358     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1359                                  {0, 0, 0, 0}};
1360     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1361     d_name.dsc$w_length = strlen(name);
1362
1363     lnmlst[0].buflen = strlen(eqv);
1364     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1365
1366     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1367     if (!(iss&1)) lib$signal(iss);
1368 }
1369 /*}}}*/
1370
1371
1372 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1373 /* my_crypt - VMS password hashing
1374  * my_crypt() provides an interface compatible with the Unix crypt()
1375  * C library function, and uses sys$hash_password() to perform VMS
1376  * password hashing.  The quadword hashed password value is returned
1377  * as a NUL-terminated 8 character string.  my_crypt() does not change
1378  * the case of its string arguments; in order to match the behavior
1379  * of LOGINOUT et al., alphabetic characters in both arguments must
1380  *  be upcased by the caller.
1381  *
1382  * - fix me to call ACM services when available
1383  */
1384 char *
1385 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1386 {
1387 #   ifndef UAI$C_PREFERRED_ALGORITHM
1388 #     define UAI$C_PREFERRED_ALGORITHM 127
1389 #   endif
1390     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1391     unsigned short int salt = 0;
1392     unsigned long int sts;
1393     struct const_dsc {
1394         unsigned short int dsc$w_length;
1395         unsigned char      dsc$b_type;
1396         unsigned char      dsc$b_class;
1397         const char *       dsc$a_pointer;
1398     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1399        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1400     struct itmlst_3 uailst[3] = {
1401         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1402         { sizeof salt, UAI$_SALT,    &salt, 0},
1403         { 0,           0,            NULL,  NULL}};
1404     static char hash[9];
1405
1406     usrdsc.dsc$w_length = strlen(usrname);
1407     usrdsc.dsc$a_pointer = usrname;
1408     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1409       switch (sts) {
1410         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1411           set_errno(EACCES);
1412           break;
1413         case RMS$_RNF:
1414           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1415           break;
1416         default:
1417           set_errno(EVMSERR);
1418       }
1419       set_vaxc_errno(sts);
1420       if (sts != RMS$_RNF) return NULL;
1421     }
1422
1423     txtdsc.dsc$w_length = strlen(textpasswd);
1424     txtdsc.dsc$a_pointer = textpasswd;
1425     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1426       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1427     }
1428
1429     return (char *) hash;
1430
1431 }  /* end of my_crypt() */
1432 /*}}}*/
1433
1434
1435 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1436 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1437 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1438
1439 /* fixup barenames that are directories for internal use.
1440  * There have been problems with the consistent handling of UNIX
1441  * style directory names when routines are presented with a name that
1442  * has no directory delimitors at all.  So this routine will eventually
1443  * fix the issue.
1444  */
1445 static char * fixup_bare_dirnames(const char * name)
1446 {
1447   if (decc_disable_to_vms_logname_translation) {
1448 /* fix me */
1449   }
1450   return NULL;
1451 }
1452
1453 /* mp_do_kill_file
1454  * A little hack to get around a bug in some implemenation of remove()
1455  * that do not know how to delete a directory
1456  *
1457  * Delete any file to which user has control access, regardless of whether
1458  * delete access is explicitly allowed.
1459  * Limitations: User must have write access to parent directory.
1460  *              Does not block signals or ASTs; if interrupted in midstream
1461  *              may leave file with an altered ACL.
1462  * HANDLE WITH CARE!
1463  */
1464 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1465 static int
1466 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1467 {
1468     char *vmsname, *rspec;
1469     char *remove_name;
1470     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1471     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1472     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1473     struct myacedef {
1474       unsigned char myace$b_length;
1475       unsigned char myace$b_type;
1476       unsigned short int myace$w_flags;
1477       unsigned long int myace$l_access;
1478       unsigned long int myace$l_ident;
1479     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1480                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1481       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1482      struct itmlst_3
1483        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1484                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1485        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1486        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1487        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1488        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1489
1490     /* Expand the input spec using RMS, since the CRTL remove() and
1491      * system services won't do this by themselves, so we may miss
1492      * a file "hiding" behind a logical name or search list. */
1493     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1494     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1495
1496     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1497       PerlMem_free(vmsname);
1498       return -1;
1499     }
1500
1501     if (decc_posix_compliant_pathnames) {
1502       /* In POSIX mode, we prefer to remove the UNIX name */
1503       rspec = vmsname;
1504       remove_name = (char *)name;
1505     }
1506     else {
1507       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1508       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1509       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1510         PerlMem_free(rspec);
1511         PerlMem_free(vmsname);
1512         return -1;
1513       }
1514       PerlMem_free(vmsname);
1515       remove_name = rspec;
1516     }
1517
1518 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1519     if (dirflag != 0) {
1520         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1521           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1522           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1523
1524           do_pathify_dirspec(name, remove_name, 0);
1525           if (!rmdir(remove_name)) {
1526
1527             PerlMem_free(remove_name);
1528             PerlMem_free(rspec);
1529             return 0;   /* Can we just get rid of it? */
1530           }
1531         }
1532         else {
1533           if (!rmdir(remove_name)) {
1534             PerlMem_free(rspec);
1535             return 0;   /* Can we just get rid of it? */
1536           }
1537         }
1538     }
1539     else
1540 #endif
1541       if (!remove(remove_name)) {
1542         PerlMem_free(rspec);
1543         return 0;   /* Can we just get rid of it? */
1544       }
1545
1546     /* If not, can changing protections help? */
1547     if (vaxc$errno != RMS$_PRV) {
1548       PerlMem_free(rspec);
1549       return -1;
1550     }
1551
1552     /* No, so we get our own UIC to use as a rights identifier,
1553      * and the insert an ACE at the head of the ACL which allows us
1554      * to delete the file.
1555      */
1556     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1557     fildsc.dsc$w_length = strlen(rspec);
1558     fildsc.dsc$a_pointer = rspec;
1559     cxt = 0;
1560     newace.myace$l_ident = oldace.myace$l_ident;
1561     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1562       switch (aclsts) {
1563         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1564           set_errno(ENOENT); break;
1565         case RMS$_DIR:
1566           set_errno(ENOTDIR); break;
1567         case RMS$_DEV:
1568           set_errno(ENODEV); break;
1569         case RMS$_SYN: case SS$_INVFILFOROP:
1570           set_errno(EINVAL); break;
1571         case RMS$_PRV:
1572           set_errno(EACCES); break;
1573         default:
1574           _ckvmssts(aclsts);
1575       }
1576       set_vaxc_errno(aclsts);
1577       PerlMem_free(rspec);
1578       return -1;
1579     }
1580     /* Grab any existing ACEs with this identifier in case we fail */
1581     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1582     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1583                     || fndsts == SS$_NOMOREACE ) {
1584       /* Add the new ACE . . . */
1585       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1586         goto yourroom;
1587
1588 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1589       if (dirflag != 0)
1590         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1591           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1592           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1593
1594           do_pathify_dirspec(name, remove_name, 0);
1595           rmsts = rmdir(remove_name);
1596           PerlMem_free(remove_name);
1597         }
1598         else {
1599         rmsts = rmdir(remove_name);
1600         }
1601       else
1602 #endif
1603         rmsts = remove(remove_name);
1604       if (rmsts) {
1605         /* We blew it - dir with files in it, no write priv for
1606          * parent directory, etc.  Put things back the way they were. */
1607         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1608           goto yourroom;
1609         if (fndsts & 1) {
1610           addlst[0].bufadr = &oldace;
1611           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1612             goto yourroom;
1613         }
1614       }
1615     }
1616
1617     yourroom:
1618     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1619     /* We just deleted it, so of course it's not there.  Some versions of
1620      * VMS seem to return success on the unlock operation anyhow (after all
1621      * the unlock is successful), but others don't.
1622      */
1623     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1624     if (aclsts & 1) aclsts = fndsts;
1625     if (!(aclsts & 1)) {
1626       set_errno(EVMSERR);
1627       set_vaxc_errno(aclsts);
1628       PerlMem_free(rspec);
1629       return -1;
1630     }
1631
1632     PerlMem_free(rspec);
1633     return rmsts;
1634
1635 }  /* end of kill_file() */
1636 /*}}}*/
1637
1638
1639 /*{{{int do_rmdir(char *name)*/
1640 int
1641 Perl_do_rmdir(pTHX_ const char *name)
1642 {
1643     char dirfile[NAM$C_MAXRSS+1];
1644     int retval;
1645     Stat_t st;
1646
1647     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1648     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1649     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1650     return retval;
1651
1652 }  /* end of do_rmdir */
1653 /*}}}*/
1654
1655 /* kill_file
1656  * Delete any file to which user has control access, regardless of whether
1657  * delete access is explicitly allowed.
1658  * Limitations: User must have write access to parent directory.
1659  *              Does not block signals or ASTs; if interrupted in midstream
1660  *              may leave file with an altered ACL.
1661  * HANDLE WITH CARE!
1662  */
1663 /*{{{int kill_file(char *name)*/
1664 int
1665 Perl_kill_file(pTHX_ const char *name)
1666 {
1667     char rspec[NAM$C_MAXRSS+1];
1668     char *tspec;
1669     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1670     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1671     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1672     struct myacedef {
1673       unsigned char myace$b_length;
1674       unsigned char myace$b_type;
1675       unsigned short int myace$w_flags;
1676       unsigned long int myace$l_access;
1677       unsigned long int myace$l_ident;
1678     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1679                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1680       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1681      struct itmlst_3
1682        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1683                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1684        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1685        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1686        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1687        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1688
1689     /* Expand the input spec using RMS, since the CRTL remove() and
1690      * system services won't do this by themselves, so we may miss
1691      * a file "hiding" behind a logical name or search list. */
1692     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS);
1693     if (tspec == NULL) return -1;
1694     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1695     /* If not, can changing protections help? */
1696     if (vaxc$errno != RMS$_PRV) return -1;
1697
1698     /* No, so we get our own UIC to use as a rights identifier,
1699      * and the insert an ACE at the head of the ACL which allows us
1700      * to delete the file.
1701      */
1702     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1703     fildsc.dsc$w_length = strlen(rspec);
1704     fildsc.dsc$a_pointer = rspec;
1705     cxt = 0;
1706     newace.myace$l_ident = oldace.myace$l_ident;
1707     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1708       switch (aclsts) {
1709         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1710           set_errno(ENOENT); break;
1711         case RMS$_DIR:
1712           set_errno(ENOTDIR); break;
1713         case RMS$_DEV:
1714           set_errno(ENODEV); break;
1715         case RMS$_SYN: case SS$_INVFILFOROP:
1716           set_errno(EINVAL); break;
1717         case RMS$_PRV:
1718           set_errno(EACCES); break;
1719         default:
1720           _ckvmssts(aclsts);
1721       }
1722       set_vaxc_errno(aclsts);
1723       return -1;
1724     }
1725     /* Grab any existing ACEs with this identifier in case we fail */
1726     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1727     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1728                     || fndsts == SS$_NOMOREACE ) {
1729       /* Add the new ACE . . . */
1730       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1731         goto yourroom;
1732       if ((rmsts = remove(name))) {
1733         /* We blew it - dir with files in it, no write priv for
1734          * parent directory, etc.  Put things back the way they were. */
1735         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1736           goto yourroom;
1737         if (fndsts & 1) {
1738           addlst[0].bufadr = &oldace;
1739           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1740             goto yourroom;
1741         }
1742       }
1743     }
1744
1745     yourroom:
1746     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1747     /* We just deleted it, so of course it's not there.  Some versions of
1748      * VMS seem to return success on the unlock operation anyhow (after all
1749      * the unlock is successful), but others don't.
1750      */
1751     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1752     if (aclsts & 1) aclsts = fndsts;
1753     if (!(aclsts & 1)) {
1754       set_errno(EVMSERR);
1755       set_vaxc_errno(aclsts);
1756       return -1;
1757     }
1758
1759     return rmsts;
1760
1761 }  /* end of kill_file() */
1762 /*}}}*/
1763
1764
1765 /*{{{int my_mkdir(char *,Mode_t)*/
1766 int
1767 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1768 {
1769   STRLEN dirlen = strlen(dir);
1770
1771   /* zero length string sometimes gives ACCVIO */
1772   if (dirlen == 0) return -1;
1773
1774   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1775    * null file name/type.  However, it's commonplace under Unix,
1776    * so we'll allow it for a gain in portability.
1777    */
1778   if (dir[dirlen-1] == '/') {
1779     char *newdir = savepvn(dir,dirlen-1);
1780     int ret = mkdir(newdir,mode);
1781     Safefree(newdir);
1782     return ret;
1783   }
1784   else return mkdir(dir,mode);
1785 }  /* end of my_mkdir */
1786 /*}}}*/
1787
1788 /*{{{int my_chdir(char *)*/
1789 int
1790 Perl_my_chdir(pTHX_ const char *dir)
1791 {
1792   STRLEN dirlen = strlen(dir);
1793
1794   /* zero length string sometimes gives ACCVIO */
1795   if (dirlen == 0) return -1;
1796   const char *dir1;
1797
1798   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1799    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
1800    * so that existing scripts do not need to be changed.
1801    */
1802   dir1 = dir;
1803   while ((dirlen > 0) && (*dir1 == ' ')) {
1804     dir1++;
1805     dirlen--;
1806   }
1807
1808   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1809    * that implies
1810    * null file name/type.  However, it's commonplace under Unix,
1811    * so we'll allow it for a gain in portability.
1812    *
1813    * - Preview- '/' will be valid soon on VMS
1814    */
1815   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1816     char *newdir = savepvn(dir1,dirlen-1);
1817     int ret = chdir(newdir);
1818     Safefree(newdir);
1819     return ret;
1820   }
1821   else return chdir(dir1);
1822 }  /* end of my_chdir */
1823 /*}}}*/
1824
1825
1826 /*{{{FILE *my_tmpfile()*/
1827 FILE *
1828 my_tmpfile(void)
1829 {
1830   FILE *fp;
1831   char *cp;
1832
1833   if ((fp = tmpfile())) return fp;
1834
1835   cp = PerlMem_malloc(L_tmpnam+24);
1836   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1837
1838   if (decc_filename_unix_only == 0)
1839     strcpy(cp,"Sys$Scratch:");
1840   else
1841     strcpy(cp,"/tmp/");
1842   tmpnam(cp+strlen(cp));
1843   strcat(cp,".Perltmp");
1844   fp = fopen(cp,"w+","fop=dlt");
1845   PerlMem_free(cp);
1846   return fp;
1847 }
1848 /*}}}*/
1849
1850
1851 #ifndef HOMEGROWN_POSIX_SIGNALS
1852 /*
1853  * The C RTL's sigaction fails to check for invalid signal numbers so we
1854  * help it out a bit.  The docs are correct, but the actual routine doesn't
1855  * do what the docs say it will.
1856  */
1857 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1858 int
1859 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1860                    struct sigaction* oact)
1861 {
1862   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1863         SETERRNO(EINVAL, SS$_INVARG);
1864         return -1;
1865   }
1866   return sigaction(sig, act, oact);
1867 }
1868 /*}}}*/
1869 #endif
1870
1871 #ifdef KILL_BY_SIGPRC
1872 #include <errnodef.h>
1873
1874 /* We implement our own kill() using the undocumented system service
1875    sys$sigprc for one of two reasons:
1876
1877    1.) If the kill() in an older CRTL uses sys$forcex, causing the
1878    target process to do a sys$exit, which usually can't be handled
1879    gracefully...certainly not by Perl and the %SIG{} mechanism.
1880
1881    2.) If the kill() in the CRTL can't be called from a signal
1882    handler without disappearing into the ether, i.e., the signal
1883    it purportedly sends is never trapped. Still true as of VMS 7.3.
1884
1885    sys$sigprc has the same parameters as sys$forcex, but throws an exception
1886    in the target process rather than calling sys$exit.
1887
1888    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1889    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1890    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
1891    with condition codes C$_SIG0+nsig*8, catching the exception on the
1892    target process and resignaling with appropriate arguments.
1893
1894    But we don't have that VMS 7.0+ exception handler, so if you
1895    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
1896
1897    Also note that SIGTERM is listed in the docs as being "unimplemented",
1898    yet always seems to be signaled with a VMS condition code of 4 (and
1899    correctly handled for that code).  So we hardwire it in.
1900
1901    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1902    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
1903    than signalling with an unrecognized (and unhandled by CRTL) code.
1904 */
1905
1906 #define _MY_SIG_MAX 17
1907
1908 static unsigned int
1909 Perl_sig_to_vmscondition_int(int sig)
1910 {
1911     static unsigned int sig_code[_MY_SIG_MAX+1] =
1912     {
1913         0,                  /*  0 ZERO     */
1914         SS$_HANGUP,         /*  1 SIGHUP   */
1915         SS$_CONTROLC,       /*  2 SIGINT   */
1916         SS$_CONTROLY,       /*  3 SIGQUIT  */
1917         SS$_RADRMOD,        /*  4 SIGILL   */
1918         SS$_BREAK,          /*  5 SIGTRAP  */
1919         SS$_OPCCUS,         /*  6 SIGABRT  */
1920         SS$_COMPAT,         /*  7 SIGEMT   */
1921 #ifdef __VAX
1922         SS$_FLTOVF,         /*  8 SIGFPE VAX */
1923 #else
1924         SS$_HPARITH,        /*  8 SIGFPE AXP */
1925 #endif
1926         SS$_ABORT,          /*  9 SIGKILL  */
1927         SS$_ACCVIO,         /* 10 SIGBUS   */
1928         SS$_ACCVIO,         /* 11 SIGSEGV  */
1929         SS$_BADPARAM,       /* 12 SIGSYS   */
1930         SS$_NOMBX,          /* 13 SIGPIPE  */
1931         SS$_ASTFLT,         /* 14 SIGALRM  */
1932         4,                  /* 15 SIGTERM  */
1933         0,                  /* 16 SIGUSR1  */
1934         0                   /* 17 SIGUSR2  */
1935     };
1936
1937 #if __VMS_VER >= 60200000
1938     static int initted = 0;
1939     if (!initted) {
1940         initted = 1;
1941         sig_code[16] = C$_SIGUSR1;
1942         sig_code[17] = C$_SIGUSR2;
1943     }
1944 #endif
1945
1946     if (sig < _SIG_MIN) return 0;
1947     if (sig > _MY_SIG_MAX) return 0;
1948     return sig_code[sig];
1949 }
1950
1951 unsigned int
1952 Perl_sig_to_vmscondition(int sig)
1953 {
1954 #ifdef SS$_DEBUG
1955     if (vms_debug_on_exception != 0)
1956         lib$signal(SS$_DEBUG);
1957 #endif
1958     return Perl_sig_to_vmscondition_int(sig);
1959 }
1960
1961
1962 int
1963 Perl_my_kill(int pid, int sig)
1964 {
1965     dTHX;
1966     int iss;
1967     unsigned int code;
1968     int sys$sigprc(unsigned int *pidadr,
1969                      struct dsc$descriptor_s *prcname,
1970                      unsigned int code);
1971
1972      /* sig 0 means validate the PID */
1973     /*------------------------------*/
1974     if (sig == 0) {
1975         const unsigned long int jpicode = JPI$_PID;
1976         pid_t ret_pid;
1977         int status;
1978         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
1979         if ($VMS_STATUS_SUCCESS(status))
1980            return 0;
1981         switch (status) {
1982         case SS$_NOSUCHNODE:
1983         case SS$_UNREACHABLE:
1984         case SS$_NONEXPR:
1985            errno = ESRCH;
1986            break;
1987         case SS$_NOPRIV:
1988            errno = EPERM;
1989            break;
1990         default:
1991            errno = EVMSERR;
1992         }
1993         vaxc$errno=status;
1994         return -1;
1995     }
1996
1997     code = Perl_sig_to_vmscondition_int(sig);
1998
1999     if (!code) {
2000         SETERRNO(EINVAL, SS$_BADPARAM);
2001         return -1;
2002     }
2003
2004     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2005      * signals are to be sent to multiple processes.
2006      *  pid = 0 - all processes in group except ones that the system exempts
2007      *  pid = -1 - all processes except ones that the system exempts
2008      *  pid = -n - all processes in group (abs(n)) except ...
2009      * For now, just report as not supported.
2010      */
2011
2012     if (pid <= 0) {
2013         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2014         return -1;
2015     }
2016
2017     iss = sys$sigprc((unsigned int *)&pid,0,code);
2018     if (iss&1) return 0;
2019
2020     switch (iss) {
2021       case SS$_NOPRIV:
2022         set_errno(EPERM);  break;
2023       case SS$_NONEXPR:
2024       case SS$_NOSUCHNODE:
2025       case SS$_UNREACHABLE:
2026         set_errno(ESRCH);  break;
2027       case SS$_INSFMEM:
2028         set_errno(ENOMEM); break;
2029       default:
2030         _ckvmssts(iss);
2031         set_errno(EVMSERR);
2032     }
2033     set_vaxc_errno(iss);
2034
2035     return -1;
2036 }
2037 #endif
2038
2039 /* Routine to convert a VMS status code to a UNIX status code.
2040 ** More tricky than it appears because of conflicting conventions with
2041 ** existing code.
2042 **
2043 ** VMS status codes are a bit mask, with the least significant bit set for
2044 ** success.
2045 **
2046 ** Special UNIX status of EVMSERR indicates that no translation is currently
2047 ** available, and programs should check the VMS status code.
2048 **
2049 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2050 ** decoding.
2051 */
2052
2053 #ifndef C_FACILITY_NO
2054 #define C_FACILITY_NO 0x350000
2055 #endif
2056 #ifndef DCL_IVVERB
2057 #define DCL_IVVERB 0x38090
2058 #endif
2059
2060 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2061 {
2062 int facility;
2063 int fac_sp;
2064 int msg_no;
2065 int msg_status;
2066 int unix_status;
2067
2068   /* Assume the best or the worst */
2069   if (vms_status & STS$M_SUCCESS)
2070     unix_status = 0;
2071   else
2072     unix_status = EVMSERR;
2073
2074   msg_status = vms_status & ~STS$M_CONTROL;
2075
2076   facility = vms_status & STS$M_FAC_NO;
2077   fac_sp = vms_status & STS$M_FAC_SP;
2078   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2079
2080   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2081     switch(msg_no) {
2082     case SS$_NORMAL:
2083         unix_status = 0;
2084         break;
2085     case SS$_ACCVIO:
2086         unix_status = EFAULT;
2087         break;
2088     case SS$_DEVOFFLINE:
2089         unix_status = EBUSY;
2090         break;
2091     case SS$_CLEARED:
2092         unix_status = ENOTCONN;
2093         break;
2094     case SS$_IVCHAN:
2095     case SS$_IVLOGNAM:
2096     case SS$_BADPARAM:
2097     case SS$_IVLOGTAB:
2098     case SS$_NOLOGNAM:
2099     case SS$_NOLOGTAB:
2100     case SS$_INVFILFOROP:
2101     case SS$_INVARG:
2102     case SS$_NOSUCHID:
2103     case SS$_IVIDENT:
2104         unix_status = EINVAL;
2105         break;
2106     case SS$_UNSUPPORTED:
2107         unix_status = ENOTSUP;
2108         break;
2109     case SS$_FILACCERR:
2110     case SS$_NOGRPPRV:
2111     case SS$_NOSYSPRV:
2112         unix_status = EACCES;
2113         break;
2114     case SS$_DEVICEFULL:
2115         unix_status = ENOSPC;
2116         break;
2117     case SS$_NOSUCHDEV:
2118         unix_status = ENODEV;
2119         break;
2120     case SS$_NOSUCHFILE:
2121     case SS$_NOSUCHOBJECT:
2122         unix_status = ENOENT;
2123         break;
2124     case SS$_ABORT:                                 /* Fatal case */
2125     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2126     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2127         unix_status = EINTR;
2128         break;
2129     case SS$_BUFFEROVF:
2130         unix_status = E2BIG;
2131         break;
2132     case SS$_INSFMEM:
2133         unix_status = ENOMEM;
2134         break;
2135     case SS$_NOPRIV:
2136         unix_status = EPERM;
2137         break;
2138     case SS$_NOSUCHNODE:
2139     case SS$_UNREACHABLE:
2140         unix_status = ESRCH;
2141         break;
2142     case SS$_NONEXPR:
2143         unix_status = ECHILD;
2144         break;
2145     default:
2146         if ((facility == 0) && (msg_no < 8)) {
2147           /* These are not real VMS status codes so assume that they are
2148           ** already UNIX status codes
2149           */
2150           unix_status = msg_no;
2151           break;
2152         }
2153     }
2154   }
2155   else {
2156     /* Translate a POSIX exit code to a UNIX exit code */
2157     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2158         unix_status = (msg_no & 0x07F8) >> 3;
2159     }
2160     else {
2161
2162          /* Documented traditional behavior for handling VMS child exits */
2163         /*--------------------------------------------------------------*/
2164         if (child_flag != 0) {
2165
2166              /* Success / Informational return 0 */
2167             /*----------------------------------*/
2168             if (msg_no & STS$K_SUCCESS)
2169                 return 0;
2170
2171              /* Warning returns 1 */
2172             /*-------------------*/
2173             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2174                 return 1;
2175
2176              /* Everything else pass through the severity bits */
2177             /*------------------------------------------------*/
2178             return (msg_no & STS$M_SEVERITY);
2179         }
2180
2181          /* Normal VMS status to ERRNO mapping attempt */
2182         /*--------------------------------------------*/
2183         switch(msg_status) {
2184         /* case RMS$_EOF: */ /* End of File */
2185         case RMS$_FNF:  /* File Not Found */
2186         case RMS$_DNF:  /* Dir Not Found */
2187                 unix_status = ENOENT;
2188                 break;
2189         case RMS$_RNF:  /* Record Not Found */
2190                 unix_status = ESRCH;
2191                 break;
2192         case RMS$_DIR:
2193                 unix_status = ENOTDIR;
2194                 break;
2195         case RMS$_DEV:
2196                 unix_status = ENODEV;
2197                 break;
2198         case RMS$_IFI:
2199         case RMS$_FAC:
2200         case RMS$_ISI:
2201                 unix_status = EBADF;
2202                 break;
2203         case RMS$_FEX:
2204                 unix_status = EEXIST;
2205                 break;
2206         case RMS$_SYN:
2207         case RMS$_FNM:
2208         case LIB$_INVSTRDES:
2209         case LIB$_INVARG:
2210         case LIB$_NOSUCHSYM:
2211         case LIB$_INVSYMNAM:
2212         case DCL_IVVERB:
2213                 unix_status = EINVAL;
2214                 break;
2215         case CLI$_BUFOVF:
2216         case RMS$_RTB:
2217         case CLI$_TKNOVF:
2218         case CLI$_RSLOVF:
2219                 unix_status = E2BIG;
2220                 break;
2221         case RMS$_PRV:  /* No privilege */
2222         case RMS$_ACC:  /* ACP file access failed */
2223         case RMS$_WLK:  /* Device write locked */
2224                 unix_status = EACCES;
2225                 break;
2226         /* case RMS$_NMF: */  /* No more files */
2227         }
2228     }
2229   }
2230
2231   return unix_status;
2232 }
2233
2234 /* Try to guess at what VMS error status should go with a UNIX errno
2235  * value.  This is hard to do as there could be many possible VMS
2236  * error statuses that caused the errno value to be set.
2237  */
2238
2239 int Perl_unix_status_to_vms(int unix_status)
2240 {
2241 int test_unix_status;
2242
2243      /* Trivial cases first */
2244     /*---------------------*/
2245     if (unix_status == EVMSERR)
2246         return vaxc$errno;
2247
2248      /* Is vaxc$errno sane? */
2249     /*---------------------*/
2250     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2251     if (test_unix_status == unix_status)
2252         return vaxc$errno;
2253
2254      /* If way out of range, must be VMS code already */
2255     /*-----------------------------------------------*/
2256     if (unix_status > EVMSERR)
2257         return unix_status;
2258
2259      /* If out of range, punt */
2260     /*-----------------------*/
2261     if (unix_status > __ERRNO_MAX)
2262         return SS$_ABORT;
2263
2264
2265      /* Ok, now we have to do it the hard way. */
2266     /*----------------------------------------*/
2267     switch(unix_status) {
2268     case 0:     return SS$_NORMAL;
2269     case EPERM: return SS$_NOPRIV;
2270     case ENOENT: return SS$_NOSUCHOBJECT;
2271     case ESRCH: return SS$_UNREACHABLE;
2272     case EINTR: return SS$_ABORT;
2273     /* case EIO: */
2274     /* case ENXIO:  */
2275     case E2BIG: return SS$_BUFFEROVF;
2276     /* case ENOEXEC */
2277     case EBADF: return RMS$_IFI;
2278     case ECHILD: return SS$_NONEXPR;
2279     /* case EAGAIN */
2280     case ENOMEM: return SS$_INSFMEM;
2281     case EACCES: return SS$_FILACCERR;
2282     case EFAULT: return SS$_ACCVIO;
2283     /* case ENOTBLK */
2284     case EBUSY: return SS$_DEVOFFLINE;
2285     case EEXIST: return RMS$_FEX;
2286     /* case EXDEV */
2287     case ENODEV: return SS$_NOSUCHDEV;
2288     case ENOTDIR: return RMS$_DIR;
2289     /* case EISDIR */
2290     case EINVAL: return SS$_INVARG;
2291     /* case ENFILE */
2292     /* case EMFILE */
2293     /* case ENOTTY */
2294     /* case ETXTBSY */
2295     /* case EFBIG */
2296     case ENOSPC: return SS$_DEVICEFULL;
2297     case ESPIPE: return LIB$_INVARG;
2298     /* case EROFS: */
2299     /* case EMLINK: */
2300     /* case EPIPE: */
2301     /* case EDOM */
2302     case ERANGE: return LIB$_INVARG;
2303     /* case EWOULDBLOCK */
2304     /* case EINPROGRESS */
2305     /* case EALREADY */
2306     /* case ENOTSOCK */
2307     /* case EDESTADDRREQ */
2308     /* case EMSGSIZE */
2309     /* case EPROTOTYPE */
2310     /* case ENOPROTOOPT */
2311     /* case EPROTONOSUPPORT */
2312     /* case ESOCKTNOSUPPORT */
2313     /* case EOPNOTSUPP */
2314     /* case EPFNOSUPPORT */
2315     /* case EAFNOSUPPORT */
2316     /* case EADDRINUSE */
2317     /* case EADDRNOTAVAIL */
2318     /* case ENETDOWN */
2319     /* case ENETUNREACH */
2320     /* case ENETRESET */
2321     /* case ECONNABORTED */
2322     /* case ECONNRESET */
2323     /* case ENOBUFS */
2324     /* case EISCONN */
2325     case ENOTCONN: return SS$_CLEARED;
2326     /* case ESHUTDOWN */
2327     /* case ETOOMANYREFS */
2328     /* case ETIMEDOUT */
2329     /* case ECONNREFUSED */
2330     /* case ELOOP */
2331     /* case ENAMETOOLONG */
2332     /* case EHOSTDOWN */
2333     /* case EHOSTUNREACH */
2334     /* case ENOTEMPTY */
2335     /* case EPROCLIM */
2336     /* case EUSERS  */
2337     /* case EDQUOT  */
2338     /* case ENOMSG  */
2339     /* case EIDRM */
2340     /* case EALIGN */
2341     /* case ESTALE */
2342     /* case EREMOTE */
2343     /* case ENOLCK */
2344     /* case ENOSYS */
2345     /* case EFTYPE */
2346     /* case ECANCELED */
2347     /* case EFAIL */
2348     /* case EINPROG */
2349     case ENOTSUP:
2350         return SS$_UNSUPPORTED;
2351     /* case EDEADLK */
2352     /* case ENWAIT */
2353     /* case EILSEQ */
2354     /* case EBADCAT */
2355     /* case EBADMSG */
2356     /* case EABANDONED */
2357     default:
2358         return SS$_ABORT; /* punt */
2359     }
2360
2361   return SS$_ABORT; /* Should not get here */
2362 }
2363
2364
2365 /* default piping mailbox size */
2366 #define PERL_BUFSIZ        512
2367
2368
2369 static void
2370 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2371 {
2372   unsigned long int mbxbufsiz;
2373   static unsigned long int syssize = 0;
2374   unsigned long int dviitm = DVI$_DEVNAM;
2375   char csize[LNM$C_NAMLENGTH+1];
2376   int sts;
2377
2378   if (!syssize) {
2379     unsigned long syiitm = SYI$_MAXBUF;
2380     /*
2381      * Get the SYSGEN parameter MAXBUF
2382      *
2383      * If the logical 'PERL_MBX_SIZE' is defined
2384      * use the value of the logical instead of PERL_BUFSIZ, but
2385      * keep the size between 128 and MAXBUF.
2386      *
2387      */
2388     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2389   }
2390
2391   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2392       mbxbufsiz = atoi(csize);
2393   } else {
2394       mbxbufsiz = PERL_BUFSIZ;
2395   }
2396   if (mbxbufsiz < 128) mbxbufsiz = 128;
2397   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2398
2399   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2400
2401   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2402   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2403
2404 }  /* end of create_mbx() */
2405
2406
2407 /*{{{  my_popen and my_pclose*/
2408
2409 typedef struct _iosb           IOSB;
2410 typedef struct _iosb*         pIOSB;
2411 typedef struct _pipe           Pipe;
2412 typedef struct _pipe*         pPipe;
2413 typedef struct pipe_details    Info;
2414 typedef struct pipe_details*  pInfo;
2415 typedef struct _srqp            RQE;
2416 typedef struct _srqp*          pRQE;
2417 typedef struct _tochildbuf      CBuf;
2418 typedef struct _tochildbuf*    pCBuf;
2419
2420 struct _iosb {
2421     unsigned short status;
2422     unsigned short count;
2423     unsigned long  dvispec;
2424 };
2425
2426 #pragma member_alignment save
2427 #pragma nomember_alignment quadword
2428 struct _srqp {          /* VMS self-relative queue entry */
2429     unsigned long qptr[2];
2430 };
2431 #pragma member_alignment restore
2432 static RQE  RQE_ZERO = {0,0};
2433
2434 struct _tochildbuf {
2435     RQE             q;
2436     int             eof;
2437     unsigned short  size;
2438     char            *buf;
2439 };
2440
2441 struct _pipe {
2442     RQE            free;
2443     RQE            wait;
2444     int            fd_out;
2445     unsigned short chan_in;
2446     unsigned short chan_out;
2447     char          *buf;
2448     unsigned int   bufsize;
2449     IOSB           iosb;
2450     IOSB           iosb2;
2451     int           *pipe_done;
2452     int            retry;
2453     int            type;
2454     int            shut_on_empty;
2455     int            need_wake;
2456     pPipe         *home;
2457     pInfo          info;
2458     pCBuf          curr;
2459     pCBuf          curr2;
2460 #if defined(PERL_IMPLICIT_CONTEXT)
2461     void            *thx;           /* Either a thread or an interpreter */
2462                                     /* pointer, depending on how we're built */
2463 #endif
2464 };
2465
2466
2467 struct pipe_details
2468 {
2469     pInfo           next;
2470     PerlIO *fp;  /* file pointer to pipe mailbox */
2471     int useFILE; /* using stdio, not perlio */
2472     int pid;   /* PID of subprocess */
2473     int mode;  /* == 'r' if pipe open for reading */
2474     int done;  /* subprocess has completed */
2475     int waiting; /* waiting for completion/closure */
2476     int             closing;        /* my_pclose is closing this pipe */
2477     unsigned long   completion;     /* termination status of subprocess */
2478     pPipe           in;             /* pipe in to sub */
2479     pPipe           out;            /* pipe out of sub */
2480     pPipe           err;            /* pipe of sub's sys$error */
2481     int             in_done;        /* true when in pipe finished */
2482     int             out_done;
2483     int             err_done;
2484 };
2485
2486 struct exit_control_block
2487 {
2488     struct exit_control_block *flink;
2489     unsigned long int   (*exit_routine)();
2490     unsigned long int arg_count;
2491     unsigned long int *status_address;
2492     unsigned long int exit_status;
2493 };
2494
2495 typedef struct _closed_pipes    Xpipe;
2496 typedef struct _closed_pipes*  pXpipe;
2497
2498 struct _closed_pipes {
2499     int             pid;            /* PID of subprocess */
2500     unsigned long   completion;     /* termination status of subprocess */
2501 };
2502 #define NKEEPCLOSED 50
2503 static Xpipe closed_list[NKEEPCLOSED];
2504 static int   closed_index = 0;
2505 static int   closed_num = 0;
2506
2507 #define RETRY_DELAY     "0 ::0.20"
2508 #define MAX_RETRY              50
2509
2510 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2511 static unsigned long mypid;
2512 static unsigned long delaytime[2];
2513
2514 static pInfo open_pipes = NULL;
2515 static $DESCRIPTOR(nl_desc, "NL:");
2516
2517 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2518
2519
2520
2521 static unsigned long int
2522 pipe_exit_routine(pTHX)
2523 {
2524     pInfo info;
2525     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2526     int sts, did_stuff, need_eof, j;
2527
2528     /*
2529         flush any pending i/o
2530     */
2531     info = open_pipes;
2532     while (info) {
2533         if (info->fp) {
2534            if (!info->useFILE)
2535                PerlIO_flush(info->fp);   /* first, flush data */
2536            else
2537                fflush((FILE *)info->fp);
2538         }
2539         info = info->next;
2540     }
2541
2542     /*
2543      next we try sending an EOF...ignore if doesn't work, make sure we
2544      don't hang
2545     */
2546     did_stuff = 0;
2547     info = open_pipes;
2548
2549     while (info) {
2550       int need_eof;
2551       _ckvmssts_noperl(sys$setast(0));
2552       if (info->in && !info->in->shut_on_empty) {
2553         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2554                           0, 0, 0, 0, 0, 0));
2555         info->waiting = 1;
2556         did_stuff = 1;
2557       }
2558       _ckvmssts_noperl(sys$setast(1));
2559       info = info->next;
2560     }
2561
2562     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2563
2564     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2565         int nwait = 0;
2566
2567         info = open_pipes;
2568         while (info) {
2569           _ckvmssts_noperl(sys$setast(0));
2570           if (info->waiting && info->done)
2571                 info->waiting = 0;
2572           nwait += info->waiting;
2573           _ckvmssts_noperl(sys$setast(1));
2574           info = info->next;
2575         }
2576         if (!nwait) break;
2577         sleep(1);
2578     }
2579
2580     did_stuff = 0;
2581     info = open_pipes;
2582     while (info) {
2583       _ckvmssts_noperl(sys$setast(0));
2584       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2585         sts = sys$forcex(&info->pid,0,&abort);
2586         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2587         did_stuff = 1;
2588       }
2589       _ckvmssts_noperl(sys$setast(1));
2590       info = info->next;
2591     }
2592
2593     /* again, wait for effect */
2594
2595     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2596         int nwait = 0;
2597
2598         info = open_pipes;
2599         while (info) {
2600           _ckvmssts_noperl(sys$setast(0));
2601           if (info->waiting && info->done)
2602                 info->waiting = 0;
2603           nwait += info->waiting;
2604           _ckvmssts_noperl(sys$setast(1));
2605           info = info->next;
2606         }
2607         if (!nwait) break;
2608         sleep(1);
2609     }
2610
2611     info = open_pipes;
2612     while (info) {
2613       _ckvmssts_noperl(sys$setast(0));
2614       if (!info->done) {  /* We tried to be nice . . . */
2615         sts = sys$delprc(&info->pid,0);
2616         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2617       }
2618       _ckvmssts_noperl(sys$setast(1));
2619       info = info->next;
2620     }
2621
2622     while(open_pipes) {
2623       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2624       else if (!(sts & 1)) retsts = sts;
2625     }
2626     return retsts;
2627 }
2628
2629 static struct exit_control_block pipe_exitblock =
2630        {(struct exit_control_block *) 0,
2631         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2632
2633 static void pipe_mbxtofd_ast(pPipe p);
2634 static void pipe_tochild1_ast(pPipe p);
2635 static void pipe_tochild2_ast(pPipe p);
2636
2637 static void
2638 popen_completion_ast(pInfo info)
2639 {
2640   pInfo i = open_pipes;
2641   int iss;
2642   int sts;
2643   pXpipe x;
2644
2645   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2646   closed_list[closed_index].pid = info->pid;
2647   closed_list[closed_index].completion = info->completion;
2648   closed_index++;
2649   if (closed_index == NKEEPCLOSED)
2650     closed_index = 0;
2651   closed_num++;
2652
2653   while (i) {
2654     if (i == info) break;
2655     i = i->next;
2656   }
2657   if (!i) return;       /* unlinked, probably freed too */
2658
2659   info->done = TRUE;
2660
2661 /*
2662     Writing to subprocess ...
2663             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2664
2665             chan_out may be waiting for "done" flag, or hung waiting
2666             for i/o completion to child...cancel the i/o.  This will
2667             put it into "snarf mode" (done but no EOF yet) that discards
2668             input.
2669
2670     Output from subprocess (stdout, stderr) needs to be flushed and
2671     shut down.   We try sending an EOF, but if the mbx is full the pipe
2672     routine should still catch the "shut_on_empty" flag, telling it to
2673     use immediate-style reads so that "mbx empty" -> EOF.
2674
2675
2676 */
2677   if (info->in && !info->in_done) {               /* only for mode=w */
2678         if (info->in->shut_on_empty && info->in->need_wake) {
2679             info->in->need_wake = FALSE;
2680             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2681         } else {
2682             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2683         }
2684   }
2685
2686   if (info->out && !info->out_done) {             /* were we also piping output? */
2687       info->out->shut_on_empty = TRUE;
2688       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2689       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2690       _ckvmssts_noperl(iss);
2691   }
2692
2693   if (info->err && !info->err_done) {        /* we were piping stderr */
2694         info->err->shut_on_empty = TRUE;
2695         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2696         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2697         _ckvmssts_noperl(iss);
2698   }
2699   _ckvmssts_noperl(sys$setef(pipe_ef));
2700
2701 }
2702
2703 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2704 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2705
2706 /*
2707     we actually differ from vmstrnenv since we use this to
2708     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2709     are pointing to the same thing
2710 */
2711
2712 static unsigned short
2713 popen_translate(pTHX_ char *logical, char *result)
2714 {
2715     int iss;
2716     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2717     $DESCRIPTOR(d_log,"");
2718     struct _il3 {
2719         unsigned short length;
2720         unsigned short code;
2721         char *         buffer_addr;
2722         unsigned short *retlenaddr;
2723     } itmlst[2];
2724     unsigned short l, ifi;
2725
2726     d_log.dsc$a_pointer = logical;
2727     d_log.dsc$w_length  = strlen(logical);
2728
2729     itmlst[0].code = LNM$_STRING;
2730     itmlst[0].length = 255;
2731     itmlst[0].buffer_addr = result;
2732     itmlst[0].retlenaddr = &l;
2733
2734     itmlst[1].code = 0;
2735     itmlst[1].length = 0;
2736     itmlst[1].buffer_addr = 0;
2737     itmlst[1].retlenaddr = 0;
2738
2739     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2740     if (iss == SS$_NOLOGNAM) {
2741         iss = SS$_NORMAL;
2742         l = 0;
2743     }
2744     if (!(iss&1)) lib$signal(iss);
2745     result[l] = '\0';
2746 /*
2747     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
2748     strip it off and return the ifi, if any
2749 */
2750     ifi  = 0;
2751     if (result[0] == 0x1b && result[1] == 0x00) {
2752         memmove(&ifi,result+2,2);
2753         strcpy(result,result+4);
2754     }
2755     return ifi;     /* this is the RMS internal file id */
2756 }
2757
2758 static void pipe_infromchild_ast(pPipe p);
2759
2760 /*
2761     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2762     inside an AST routine without worrying about reentrancy and which Perl
2763     memory allocator is being used.
2764
2765     We read data and queue up the buffers, then spit them out one at a
2766     time to the output mailbox when the output mailbox is ready for one.
2767
2768 */
2769 #define INITIAL_TOCHILDQUEUE  2
2770
2771 static pPipe
2772 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2773 {
2774     pPipe p;
2775     pCBuf b;
2776     char mbx1[64], mbx2[64];
2777     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2778                                       DSC$K_CLASS_S, mbx1},
2779                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2780                                       DSC$K_CLASS_S, mbx2};
2781     unsigned int dviitm = DVI$_DEVBUFSIZ;
2782     int j, n;
2783
2784     n = sizeof(Pipe);
2785     _ckvmssts(lib$get_vm(&n, &p));
2786
2787     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2788     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2789     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2790
2791     p->buf           = 0;
2792     p->shut_on_empty = FALSE;
2793     p->need_wake     = FALSE;
2794     p->type          = 0;
2795     p->retry         = 0;
2796     p->iosb.status   = SS$_NORMAL;
2797     p->iosb2.status  = SS$_NORMAL;
2798     p->free          = RQE_ZERO;
2799     p->wait          = RQE_ZERO;
2800     p->curr          = 0;
2801     p->curr2         = 0;
2802     p->info          = 0;
2803 #ifdef PERL_IMPLICIT_CONTEXT
2804     p->thx           = aTHX;
2805 #endif
2806
2807     n = sizeof(CBuf) + p->bufsize;
2808
2809     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2810         _ckvmssts(lib$get_vm(&n, &b));
2811         b->buf = (char *) b + sizeof(CBuf);
2812         _ckvmssts(lib$insqhi(b, &p->free));
2813     }
2814
2815     pipe_tochild2_ast(p);
2816     pipe_tochild1_ast(p);
2817     strcpy(wmbx, mbx1);
2818     strcpy(rmbx, mbx2);
2819     return p;
2820 }
2821
2822 /*  reads the MBX Perl is writing, and queues */
2823
2824 static void
2825 pipe_tochild1_ast(pPipe p)
2826 {
2827     pCBuf b = p->curr;
2828     int iss = p->iosb.status;
2829     int eof = (iss == SS$_ENDOFFILE);
2830     int sts;
2831 #ifdef PERL_IMPLICIT_CONTEXT
2832     pTHX = p->thx;
2833 #endif
2834
2835     if (p->retry) {
2836         if (eof) {
2837             p->shut_on_empty = TRUE;
2838             b->eof     = TRUE;
2839             _ckvmssts(sys$dassgn(p->chan_in));
2840         } else  {
2841             _ckvmssts(iss);
2842         }
2843
2844         b->eof  = eof;
2845         b->size = p->iosb.count;
2846         _ckvmssts(sts = lib$insqhi(b, &p->wait));
2847         if (p->need_wake) {
2848             p->need_wake = FALSE;
2849             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2850         }
2851     } else {
2852         p->retry = 1;   /* initial call */
2853     }
2854
2855     if (eof) {                  /* flush the free queue, return when done */
2856         int n = sizeof(CBuf) + p->bufsize;
2857         while (1) {
2858             iss = lib$remqti(&p->free, &b);
2859             if (iss == LIB$_QUEWASEMP) return;
2860             _ckvmssts(iss);
2861             _ckvmssts(lib$free_vm(&n, &b));
2862         }
2863     }
2864
2865     iss = lib$remqti(&p->free, &b);
2866     if (iss == LIB$_QUEWASEMP) {
2867         int n = sizeof(CBuf) + p->bufsize;
2868         _ckvmssts(lib$get_vm(&n, &b));
2869         b->buf = (char *) b + sizeof(CBuf);
2870     } else {
2871        _ckvmssts(iss);
2872     }
2873
2874     p->curr = b;
2875     iss = sys$qio(0,p->chan_in,
2876              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2877              &p->iosb,
2878              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2879     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2880     _ckvmssts(iss);
2881 }
2882
2883
2884 /* writes queued buffers to output, waits for each to complete before
2885    doing the next */
2886
2887 static void
2888 pipe_tochild2_ast(pPipe p)
2889 {
2890     pCBuf b = p->curr2;
2891     int iss = p->iosb2.status;
2892     int n = sizeof(CBuf) + p->bufsize;
2893     int done = (p->info && p->info->done) ||
2894               iss == SS$_CANCEL || iss == SS$_ABORT;
2895 #if defined(PERL_IMPLICIT_CONTEXT)
2896     pTHX = p->thx;
2897 #endif
2898
2899     do {
2900         if (p->type) {         /* type=1 has old buffer, dispose */
2901             if (p->shut_on_empty) {
2902                 _ckvmssts(lib$free_vm(&n, &b));
2903             } else {
2904                 _ckvmssts(lib$insqhi(b, &p->free));
2905             }
2906             p->type = 0;
2907         }
2908
2909         iss = lib$remqti(&p->wait, &b);
2910         if (iss == LIB$_QUEWASEMP) {
2911             if (p->shut_on_empty) {
2912                 if (done) {
2913                     _ckvmssts(sys$dassgn(p->chan_out));
2914                     *p->pipe_done = TRUE;
2915                     _ckvmssts(sys$setef(pipe_ef));
2916                 } else {
2917                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2918                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2919                 }
2920                 return;
2921             }
2922             p->need_wake = TRUE;
2923             return;
2924         }
2925         _ckvmssts(iss);
2926         p->type = 1;
2927     } while (done);
2928
2929
2930     p->curr2 = b;
2931     if (b->eof) {
2932         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2933             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2934     } else {
2935         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2936             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2937     }
2938
2939     return;
2940
2941 }
2942
2943
2944 static pPipe
2945 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2946 {
2947     pPipe p;
2948     char mbx1[64], mbx2[64];
2949     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2950                                       DSC$K_CLASS_S, mbx1},
2951                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2952                                       DSC$K_CLASS_S, mbx2};
2953     unsigned int dviitm = DVI$_DEVBUFSIZ;
2954
2955     int n = sizeof(Pipe);
2956     _ckvmssts(lib$get_vm(&n, &p));
2957     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2958     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2959
2960     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2961     n = p->bufsize * sizeof(char);
2962     _ckvmssts(lib$get_vm(&n, &p->buf));
2963     p->shut_on_empty = FALSE;
2964     p->info   = 0;
2965     p->type   = 0;
2966     p->iosb.status = SS$_NORMAL;
2967 #if defined(PERL_IMPLICIT_CONTEXT)
2968     p->thx = aTHX;
2969 #endif
2970     pipe_infromchild_ast(p);
2971
2972     strcpy(wmbx, mbx1);
2973     strcpy(rmbx, mbx2);
2974     return p;
2975 }
2976
2977 static void
2978 pipe_infromchild_ast(pPipe p)
2979 {
2980     int iss = p->iosb.status;
2981     int eof = (iss == SS$_ENDOFFILE);
2982     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2983     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2984 #if defined(PERL_IMPLICIT_CONTEXT)
2985     pTHX = p->thx;
2986 #endif
2987
2988     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
2989         _ckvmssts(sys$dassgn(p->chan_out));
2990         p->chan_out = 0;
2991     }
2992
2993     /* read completed:
2994             input shutdown if EOF from self (done or shut_on_empty)
2995             output shutdown if closing flag set (my_pclose)
2996             send data/eof from child or eof from self
2997             otherwise, re-read (snarf of data from child)
2998     */
2999
3000     if (p->type == 1) {
3001         p->type = 0;
3002         if (myeof && p->chan_in) {                  /* input shutdown */
3003             _ckvmssts(sys$dassgn(p->chan_in));
3004             p->chan_in = 0;
3005         }
3006
3007         if (p->chan_out) {
3008             if (myeof || kideof) {      /* pass EOF to parent */
3009                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3010                               pipe_infromchild_ast, p,
3011                               0, 0, 0, 0, 0, 0));
3012                 return;
3013             } else if (eof) {       /* eat EOF --- fall through to read*/
3014
3015             } else {                /* transmit data */
3016                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3017                               pipe_infromchild_ast,p,
3018                               p->buf, p->iosb.count, 0, 0, 0, 0));
3019                 return;
3020             }
3021         }
3022     }
3023
3024     /*  everything shut? flag as done */
3025
3026     if (!p->chan_in && !p->chan_out) {
3027         *p->pipe_done = TRUE;
3028         _ckvmssts(sys$setef(pipe_ef));
3029         return;
3030     }
3031
3032     /* write completed (or read, if snarfing from child)
3033             if still have input active,
3034                queue read...immediate mode if shut_on_empty so we get EOF if empty
3035             otherwise,
3036                check if Perl reading, generate EOFs as needed
3037     */
3038
3039     if (p->type == 0) {
3040         p->type = 1;
3041         if (p->chan_in) {
3042             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3043                           pipe_infromchild_ast,p,
3044                           p->buf, p->bufsize, 0, 0, 0, 0);
3045             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3046             _ckvmssts(iss);
3047         } else {           /* send EOFs for extra reads */
3048             p->iosb.status = SS$_ENDOFFILE;
3049             p->iosb.dvispec = 0;
3050             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3051                       0, 0, 0,
3052                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3053         }
3054     }
3055 }
3056
3057 static pPipe
3058 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3059 {
3060     pPipe p;
3061     char mbx[64];
3062     unsigned long dviitm = DVI$_DEVBUFSIZ;
3063     struct stat s;
3064     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3065                                       DSC$K_CLASS_S, mbx};
3066     int n = sizeof(Pipe);
3067
3068     /* things like terminals and mbx's don't need this filter */
3069     if (fd && fstat(fd,&s) == 0) {
3070         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3071         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
3072                                          DSC$K_CLASS_S, s.st_dev};
3073
3074         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
3075         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
3076             strcpy(out, s.st_dev);
3077             return 0;
3078         }
3079     }
3080
3081     _ckvmssts(lib$get_vm(&n, &p));
3082     p->fd_out = dup(fd);
3083     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3084     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3085     n = (p->bufsize+1) * sizeof(char);
3086     _ckvmssts(lib$get_vm(&n, &p->buf));
3087     p->shut_on_empty = FALSE;
3088     p->retry = 0;
3089     p->info  = 0;
3090     strcpy(out, mbx);
3091
3092     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3093                   pipe_mbxtofd_ast, p,
3094                   p->buf, p->bufsize, 0, 0, 0, 0));
3095
3096     return p;
3097 }
3098
3099 static void
3100 pipe_mbxtofd_ast(pPipe p)
3101 {
3102     int iss = p->iosb.status;
3103     int done = p->info->done;
3104     int iss2;
3105     int eof = (iss == SS$_ENDOFFILE);
3106     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3107     int err = !(iss&1) && !eof;
3108 #if defined(PERL_IMPLICIT_CONTEXT)
3109     pTHX = p->thx;
3110 #endif
3111
3112     if (done && myeof) {               /* end piping */
3113         close(p->fd_out);
3114         sys$dassgn(p->chan_in);
3115         *p->pipe_done = TRUE;
3116         _ckvmssts(sys$setef(pipe_ef));
3117         return;
3118     }
3119
3120     if (!err && !eof) {             /* good data to send to file */
3121         p->buf[p->iosb.count] = '\n';
3122         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3123         if (iss2 < 0) {
3124             p->retry++;
3125             if (p->retry < MAX_RETRY) {
3126                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3127                 return;
3128             }
3129         }
3130         p->retry = 0;
3131     } else if (err) {
3132         _ckvmssts(iss);
3133     }
3134
3135
3136     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3137           pipe_mbxtofd_ast, p,
3138           p->buf, p->bufsize, 0, 0, 0, 0);
3139     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3140     _ckvmssts(iss);
3141 }
3142
3143
3144 typedef struct _pipeloc     PLOC;
3145 typedef struct _pipeloc*   pPLOC;
3146
3147 struct _pipeloc {
3148     pPLOC   next;
3149     char    dir[NAM$C_MAXRSS+1];
3150 };
3151 static pPLOC  head_PLOC = 0;
3152
3153 void
3154 free_pipelocs(pTHX_ void *head)
3155 {
3156     pPLOC p, pnext;
3157     pPLOC *pHead = (pPLOC *)head;
3158
3159     p = *pHead;
3160     while (p) {
3161         pnext = p->next;
3162         PerlMem_free(p);
3163         p = pnext;
3164     }
3165     *pHead = 0;
3166 }
3167
3168 static void
3169 store_pipelocs(pTHX)
3170 {
3171     int    i;
3172     pPLOC  p;
3173     AV    *av = 0;
3174     SV    *dirsv;
3175     GV    *gv;
3176     char  *dir, *x;
3177     char  *unixdir;
3178     char  temp[NAM$C_MAXRSS+1];
3179     STRLEN n_a;
3180
3181     if (head_PLOC)
3182         free_pipelocs(aTHX_ &head_PLOC);
3183
3184 /*  the . directory from @INC comes last */
3185
3186     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3187     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3188     p->next = head_PLOC;
3189     head_PLOC = p;
3190     strcpy(p->dir,"./");
3191
3192 /*  get the directory from $^X */
3193
3194     unixdir = PerlMem_malloc(VMS_MAXRSS);
3195     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3196
3197 #ifdef PERL_IMPLICIT_CONTEXT
3198     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3199 #else
3200     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3201 #endif
3202         strcpy(temp, PL_origargv[0]);
3203         x = strrchr(temp,']');
3204         if (x == NULL) {
3205         x = strrchr(temp,'>');
3206           if (x == NULL) {
3207             /* It could be a UNIX path */
3208             x = strrchr(temp,'/');
3209           }
3210         }
3211         if (x)
3212           x[1] = '\0';
3213         else {
3214           /* Got a bare name, so use default directory */
3215           temp[0] = '.';
3216           temp[1] = '\0';
3217         }
3218
3219         if ((tounixpath(temp, unixdir)) != Nullch) {
3220             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3221             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3222             p->next = head_PLOC;
3223             head_PLOC = p;
3224             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3225             p->dir[NAM$C_MAXRSS] = '\0';
3226         }
3227     }
3228
3229 /*  reverse order of @INC entries, skip "." since entered above */
3230
3231 #ifdef PERL_IMPLICIT_CONTEXT
3232     if (aTHX)
3233 #endif
3234     if (PL_incgv) av = GvAVn(PL_incgv);
3235
3236     for (i = 0; av && i <= AvFILL(av); i++) {
3237         dirsv = *av_fetch(av,i,TRUE);
3238
3239         if (SvROK(dirsv)) continue;
3240         dir = SvPVx(dirsv,n_a);
3241         if (strcmp(dir,".") == 0) continue;
3242         if ((tounixpath(dir, unixdir)) == Nullch)
3243             continue;
3244
3245         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3246         p->next = head_PLOC;
3247         head_PLOC = p;
3248         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3249         p->dir[NAM$C_MAXRSS] = '\0';
3250     }
3251
3252 /* most likely spot (ARCHLIB) put first in the list */
3253
3254 #ifdef ARCHLIB_EXP
3255     if ((tounixpath(ARCHLIB_EXP, unixdir)) != Nullch) {
3256         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3257         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3258         p->next = head_PLOC;
3259         head_PLOC = p;
3260         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3261         p->dir[NAM$C_MAXRSS] = '\0';
3262     }
3263 #endif
3264     PerlMem_free(unixdir);
3265 }
3266
3267
3268 static char *
3269 find_vmspipe(pTHX)
3270 {
3271     static int   vmspipe_file_status = 0;
3272     static char  vmspipe_file[NAM$C_MAXRSS+1];
3273
3274     /* already found? Check and use ... need read+execute permission */
3275
3276     if (vmspipe_file_status == 1) {
3277         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3278          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3279             return vmspipe_file;
3280         }
3281         vmspipe_file_status = 0;
3282     }
3283
3284     /* scan through stored @INC, $^X */
3285
3286     if (vmspipe_file_status == 0) {
3287         char file[NAM$C_MAXRSS+1];
3288         pPLOC  p = head_PLOC;
3289
3290         while (p) {
3291             char * exp_res;
3292             int dirlen;
3293             strcpy(file, p->dir);
3294             dirlen = strlen(file);
3295             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3296             file[NAM$C_MAXRSS] = '\0';
3297             p = p->next;
3298
3299             exp_res = do_rmsexpand
3300                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS);
3301             if (!exp_res) continue;
3302
3303             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3304              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3305                 vmspipe_file_status = 1;
3306                 return vmspipe_file;
3307             }
3308         }
3309         vmspipe_file_status = -1;   /* failed, use tempfiles */
3310     }
3311
3312     return 0;
3313 }
3314
3315 static FILE *
3316 vmspipe_tempfile(pTHX)
3317 {
3318     char file[NAM$C_MAXRSS+1];
3319     FILE *fp;
3320     static int index = 0;
3321     Stat_t s0, s1;
3322     int cmp_result;
3323
3324     /* create a tempfile */
3325
3326     /* we can't go from   W, shr=get to  R, shr=get without
3327        an intermediate vulnerable state, so don't bother trying...
3328
3329        and lib$spawn doesn't shr=put, so have to close the write
3330
3331        So... match up the creation date/time and the FID to
3332        make sure we're dealing with the same file
3333
3334     */
3335
3336     index++;
3337     if (!decc_filename_unix_only) {
3338       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3339       fp = fopen(file,"w");
3340       if (!fp) {
3341         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3342         fp = fopen(file,"w");
3343         if (!fp) {
3344             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3345             fp = fopen(file,"w");
3346         }
3347       }
3348      }
3349      else {
3350       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3351       fp = fopen(file,"w");
3352       if (!fp) {
3353         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3354         fp = fopen(file,"w");
3355         if (!fp) {
3356           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3357           fp = fopen(file,"w");
3358         }
3359       }
3360     }
3361     if (!fp) return 0;  /* we're hosed */
3362
3363     fprintf(fp,"$! 'f$verify(0)'\n");
3364     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3365     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3366     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3367     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3368     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3369     fprintf(fp,"$ perl_del    = \"delete\"\n");
3370     fprintf(fp,"$ pif         = \"if\"\n");
3371     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3372     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3373     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3374     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3375     fprintf(fp,"$!  --- build command line to get max possible length\n");
3376     fprintf(fp,"$c=perl_popen_cmd0\n");
3377     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3378     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3379     fprintf(fp,"$x=perl_popen_cmd3\n");
3380     fprintf(fp,"$c=c+x\n");
3381     fprintf(fp,"$ perl_on\n");
3382     fprintf(fp,"$ 'c'\n");
3383     fprintf(fp,"$ perl_status = $STATUS\n");
3384     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3385     fprintf(fp,"$ perl_exit 'perl_status'\n");
3386     fsync(fileno(fp));
3387
3388     fgetname(fp, file, 1);
3389     fstat(fileno(fp), (struct stat *)&s0);
3390     fclose(fp);
3391
3392     if (decc_filename_unix_only)
3393         do_tounixspec(file, file, 0);
3394     fp = fopen(file,"r","shr=get");
3395     if (!fp) return 0;
3396     fstat(fileno(fp), (struct stat *)&s1);
3397
3398     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3399     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3400         fclose(fp);
3401         return 0;
3402     }
3403
3404     return fp;
3405 }
3406
3407
3408
3409 static PerlIO *
3410 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3411 {
3412     static int handler_set_up = FALSE;
3413     unsigned long int sts, flags = CLI$M_NOWAIT;
3414     /* The use of a GLOBAL table (as was done previously) rendered
3415      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3416      * environment.  Hence we've switched to LOCAL symbol table.
3417      */
3418     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3419     int j, wait = 0, n;
3420     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3421     char in[512], out[512], err[512], mbx[512];
3422     FILE *tpipe = 0;
3423     char tfilebuf[NAM$C_MAXRSS+1];
3424     pInfo info = NULL;
3425     char cmd_sym_name[20];
3426     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3427                                       DSC$K_CLASS_S, symbol};
3428     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3429                                       DSC$K_CLASS_S, 0};
3430     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3431                                       DSC$K_CLASS_S, cmd_sym_name};
3432     struct dsc$descriptor_s *vmscmd;
3433     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3434     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3435     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3436
3437     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3438
3439     /* once-per-program initialization...
3440        note that the SETAST calls and the dual test of pipe_ef
3441        makes sure that only the FIRST thread through here does
3442        the initialization...all other threads wait until it's
3443        done.
3444
3445        Yeah, uglier than a pthread call, it's got all the stuff inline
3446        rather than in a separate routine.
3447     */
3448
3449     if (!pipe_ef) {
3450         _ckvmssts(sys$setast(0));
3451         if (!pipe_ef) {
3452             unsigned long int pidcode = JPI$_PID;
3453             $DESCRIPTOR(d_delay, RETRY_DELAY);
3454             _ckvmssts(lib$get_ef(&pipe_ef));
3455             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3456             _ckvmssts(sys$bintim(&d_delay, delaytime));
3457         }
3458         if (!handler_set_up) {
3459           _ckvmssts(sys$dclexh(&pipe_exitblock));
3460           handler_set_up = TRUE;
3461         }
3462         _ckvmssts(sys$setast(1));
3463     }
3464
3465     /* see if we can find a VMSPIPE.COM */
3466
3467     tfilebuf[0] = '@';
3468     vmspipe = find_vmspipe(aTHX);
3469     if (vmspipe) {
3470         strcpy(tfilebuf+1,vmspipe);
3471     } else {        /* uh, oh...we're in tempfile hell */
3472         tpipe = vmspipe_tempfile(aTHX);
3473         if (!tpipe) {       /* a fish popular in Boston */
3474             if (ckWARN(WARN_PIPE)) {
3475                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3476             }
3477         return Nullfp;
3478         }
3479         fgetname(tpipe,tfilebuf+1,1);
3480     }
3481     vmspipedsc.dsc$a_pointer = tfilebuf;
3482     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3483
3484     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3485     if (!(sts & 1)) {
3486       switch (sts) {
3487         case RMS$_FNF:  case RMS$_DNF:
3488           set_errno(ENOENT); break;
3489         case RMS$_DIR:
3490           set_errno(ENOTDIR); break;
3491         case RMS$_DEV:
3492           set_errno(ENODEV); break;
3493         case RMS$_PRV:
3494           set_errno(EACCES); break;
3495         case RMS$_SYN:
3496           set_errno(EINVAL); break;
3497         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3498           set_errno(E2BIG); break;
3499         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3500           _ckvmssts(sts); /* fall through */
3501         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3502           set_errno(EVMSERR);
3503       }
3504       set_vaxc_errno(sts);
3505       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3506         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3507       }
3508       *psts = sts;
3509       return Nullfp;
3510     }
3511     n = sizeof(Info);
3512     _ckvmssts(lib$get_vm(&n, &info));
3513
3514     strcpy(mode,in_mode);
3515     info->mode = *mode;
3516     info->done = FALSE;
3517     info->completion = 0;
3518     info->closing    = FALSE;
3519     info->in         = 0;
3520     info->out        = 0;
3521     info->err        = 0;
3522     info->fp         = Nullfp;
3523     info->useFILE    = 0;
3524     info->waiting    = 0;
3525     info->in_done    = TRUE;
3526     info->out_done   = TRUE;
3527     info->err_done   = TRUE;
3528     in[0] = out[0] = err[0] = '\0';
3529
3530     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3531         info->useFILE = 1;
3532         strcpy(p,p+1);
3533     }
3534     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3535         wait = 1;
3536         strcpy(p,p+1);
3537     }
3538
3539     if (*mode == 'r') {             /* piping from subroutine */
3540
3541         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3542         if (info->out) {
3543             info->out->pipe_done = &info->out_done;
3544             info->out_done = FALSE;
3545             info->out->info = info;
3546         }
3547         if (!info->useFILE) {
3548         info->fp  = PerlIO_open(mbx, mode);
3549         } else {
3550             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3551             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3552         }
3553
3554         if (!info->fp && info->out) {
3555             sys$cancel(info->out->chan_out);
3556
3557             while (!info->out_done) {
3558                 int done;
3559                 _ckvmssts(sys$setast(0));
3560                 done = info->out_done;
3561                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3562                 _ckvmssts(sys$setast(1));
3563                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3564             }
3565
3566             if (info->out->buf) {
3567                 n = info->out->bufsize * sizeof(char);
3568                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3569             }
3570             n = sizeof(Pipe);
3571             _ckvmssts(lib$free_vm(&n, &info->out));
3572             n = sizeof(Info);
3573             _ckvmssts(lib$free_vm(&n, &info));
3574             *psts = RMS$_FNF;
3575             return Nullfp;
3576         }
3577
3578         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3579         if (info->err) {
3580             info->err->pipe_done = &info->err_done;
3581             info->err_done = FALSE;
3582             info->err->info = info;
3583         }
3584
3585     } else if (*mode == 'w') {      /* piping to subroutine */
3586
3587         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3588         if (info->out) {
3589             info->out->pipe_done = &info->out_done;
3590             info->out_done = FALSE;
3591             info->out->info = info;
3592         }
3593
3594         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3595         if (info->err) {
3596             info->err->pipe_done = &info->err_done;
3597             info->err_done = FALSE;
3598             info->err->info = info;
3599         }
3600
3601         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3602         if (!info->useFILE) {
3603             info->fp  = PerlIO_open(mbx, mode);
3604         } else {
3605             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3606             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3607         }
3608
3609         if (info->in) {
3610             info->in->pipe_done = &info->in_done;
3611             info->in_done = FALSE;
3612             info->in->info = info;
3613         }
3614
3615         /* error cleanup */
3616         if (!info->fp && info->in) {
3617             info->done = TRUE;
3618             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3619                               0, 0, 0, 0, 0, 0, 0, 0));
3620
3621             while (!info->in_done) {
3622                 int done;
3623                 _ckvmssts(sys$setast(0));
3624                 done = info->in_done;
3625                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3626                 _ckvmssts(sys$setast(1));
3627                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3628             }
3629
3630             if (info->in->buf) {
3631                 n = info->in->bufsize * sizeof(char);
3632                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3633             }
3634             n = sizeof(Pipe);
3635             _ckvmssts(lib$free_vm(&n, &info->in));
3636             n = sizeof(Info);
3637             _ckvmssts(lib$free_vm(&n, &info));
3638             *psts = RMS$_FNF;
3639             return Nullfp;
3640         }
3641
3642
3643     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3644         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3645         if (info->out) {
3646             info->out->pipe_done = &info->out_done;
3647             info->out_done = FALSE;
3648             info->out->info = info;
3649         }
3650
3651         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3652         if (info->err) {
3653             info->err->pipe_done = &info->err_done;
3654             info->err_done = FALSE;
3655             info->err->info = info;
3656         }
3657     }
3658
3659     symbol[MAX_DCL_SYMBOL] = '\0';
3660
3661     strncpy(symbol, in, MAX_DCL_SYMBOL);
3662     d_symbol.dsc$w_length = strlen(symbol);
3663     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3664
3665     strncpy(symbol, err, MAX_DCL_SYMBOL);
3666     d_symbol.dsc$w_length = strlen(symbol);
3667     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3668
3669     strncpy(symbol, out, MAX_DCL_SYMBOL);
3670     d_symbol.dsc$w_length = strlen(symbol);
3671     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3672
3673     p = vmscmd->dsc$a_pointer;
3674     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
3675     if (*p == '$') p++;                         /* remove leading $ */
3676     while (*p == ' ' || *p == '\t') p++;
3677
3678     for (j = 0; j < 4; j++) {
3679         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3680         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3681
3682     strncpy(symbol, p, MAX_DCL_SYMBOL);
3683     d_symbol.dsc$w_length = strlen(symbol);
3684     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3685
3686         if (strlen(p) > MAX_DCL_SYMBOL) {
3687             p += MAX_DCL_SYMBOL;
3688         } else {
3689             p += strlen(p);
3690         }
3691     }
3692     _ckvmssts(sys$setast(0));
3693     info->next=open_pipes;  /* prepend to list */
3694     open_pipes=info;
3695     _ckvmssts(sys$setast(1));
3696     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3697      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
3698      * have SYS$COMMAND if we need it.
3699      */
3700     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3701                       0, &info->pid, &info->completion,
3702                       0, popen_completion_ast,info,0,0,0));
3703
3704     /* if we were using a tempfile, close it now */
3705
3706     if (tpipe) fclose(tpipe);
3707
3708     /* once the subprocess is spawned, it has copied the symbols and
3709        we can get rid of ours */
3710
3711     for (j = 0; j < 4; j++) {
3712         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3713         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3714     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3715     }
3716     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
3717     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3718     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3719     vms_execfree(vmscmd);
3720
3721 #ifdef PERL_IMPLICIT_CONTEXT
3722     if (aTHX)
3723 #endif
3724     PL_forkprocess = info->pid;
3725
3726     if (wait) {
3727          int done = 0;
3728          while (!done) {
3729              _ckvmssts(sys$setast(0));
3730              done = info->done;
3731              if (!done) _ckvmssts(sys$clref(pipe_ef));
3732              _ckvmssts(sys$setast(1));
3733              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3734          }
3735         *psts = info->completion;
3736 /* Caller thinks it is open and tries to close it. */
3737 /* This causes some problems, as it changes the error status */
3738 /*        my_pclose(info->fp); */
3739     } else {
3740         *psts = SS$_NORMAL;
3741     }
3742     return info->fp;
3743 }  /* end of safe_popen */
3744
3745
3746 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
3747 PerlIO *
3748 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3749 {
3750     int sts;
3751     TAINT_ENV();
3752     TAINT_PROPER("popen");
3753     PERL_FLUSHALL_FOR_CHILD;
3754     return safe_popen(aTHX_ cmd,mode,&sts);
3755 }
3756
3757 /*}}}*/
3758
3759 /*{{{  I32 my_pclose(PerlIO *fp)*/
3760 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3761 {
3762     pInfo info, last = NULL;
3763     unsigned long int retsts;
3764     int done, iss, n;
3765
3766     for (info = open_pipes; info != NULL; last = info, info = info->next)
3767         if (info->fp == fp) break;
3768
3769     if (info == NULL) {  /* no such pipe open */
3770       set_errno(ECHILD); /* quoth POSIX */
3771       set_vaxc_errno(SS$_NONEXPR);
3772       return -1;
3773     }
3774
3775     /* If we were writing to a subprocess, insure that someone reading from
3776      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
3777      * produce an EOF record in the mailbox.
3778      *
3779      *  well, at least sometimes it *does*, so we have to watch out for
3780      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
3781      */
3782      if (info->fp) {
3783         if (!info->useFILE)
3784             PerlIO_flush(info->fp);   /* first, flush data */
3785         else
3786             fflush((FILE *)info->fp);
3787     }
3788
3789     _ckvmssts(sys$setast(0));
3790      info->closing = TRUE;
3791      done = info->done && info->in_done && info->out_done && info->err_done;
3792      /* hanging on write to Perl's input? cancel it */
3793      if (info->mode == 'r' && info->out && !info->out_done) {
3794         if (info->out->chan_out) {
3795             _ckvmssts(sys$cancel(info->out->chan_out));
3796             if (!info->out->chan_in) {   /* EOF generation, need AST */
3797                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3798             }
3799         }
3800      }
3801      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
3802          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3803                            0, 0, 0, 0, 0, 0));
3804     _ckvmssts(sys$setast(1));
3805     if (info->fp) {
3806      if (!info->useFILE)
3807         PerlIO_close(info->fp);
3808      else
3809         fclose((FILE *)info->fp);
3810     }
3811      /*
3812         we have to wait until subprocess completes, but ALSO wait until all
3813         the i/o completes...otherwise we'll be freeing the "info" structure
3814         that the i/o ASTs could still be using...
3815      */
3816
3817      while (!done) {
3818          _ckvmssts(sys$setast(0));
3819          done = info->done && info->in_done && info->out_done && info->err_done;
3820          if (!done) _ckvmssts(sys$clref(pipe_ef));
3821          _ckvmssts(sys$setast(1));
3822          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3823      }
3824      retsts = info->completion;
3825
3826     /* remove from list of open pipes */
3827     _ckvmssts(sys$setast(0));
3828     if (last) last->next = info->next;
3829     else open_pipes = info->next;
3830     _ckvmssts(sys$setast(1));
3831
3832     /* free buffers and structures */
3833
3834     if (info->in) {
3835         if (info->in->buf) {
3836             n = info->in->bufsize * sizeof(char);
3837             _ckvmssts(lib$free_vm(&n, &info->in->buf));
3838         }
3839         n = sizeof(Pipe);
3840         _ckvmssts(lib$free_vm(&n, &info->in));
3841     }
3842     if (info->out) {
3843         if (info->out->buf) {
3844             n = info->out->bufsize * sizeof(char);
3845             _ckvmssts(lib$free_vm(&n, &info->out->buf));
3846         }
3847         n = sizeof(Pipe);
3848         _ckvmssts(lib$free_vm(&n, &info->out));
3849     }
3850     if (info->err) {
3851         if (info->err->buf) {
3852             n = info->err->bufsize * sizeof(char);
3853             _ckvmssts(lib$free_vm(&n, &info->err->buf));
3854         }
3855         n = sizeof(Pipe);
3856         _ckvmssts(lib$free_vm(&n, &info->err));
3857     }
3858     n = sizeof(Info);
3859     _ckvmssts(lib$free_vm(&n, &info));
3860
3861     return retsts;
3862
3863 }  /* end of my_pclose() */
3864
3865 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3866   /* Roll our own prototype because we want this regardless of whether
3867    * _VMS_WAIT is defined.
3868    */
3869   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3870 #endif
3871 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3872    created with popen(); otherwise partially emulate waitpid() unless
3873    we have a suitable one from the CRTL that came with VMS 7.2 and later.
3874    Also check processes not considered by the CRTL waitpid().
3875  */
3876 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3877 Pid_t
3878 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3879 {
3880     pInfo info;
3881     int done;
3882     int sts;
3883     int j;
3884
3885     if (statusp) *statusp = 0;
3886
3887     for (info = open_pipes; info != NULL; info = info->next)
3888         if (info->pid == pid) break;
3889
3890     if (info != NULL) {  /* we know about this child */
3891       while (!info->done) {
3892           _ckvmssts(sys$setast(0));
3893           done = info->done;
3894           if (!done) _ckvmssts(sys$clref(pipe_ef));
3895           _ckvmssts(sys$setast(1));
3896           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3897       }
3898
3899       if (statusp) *statusp = info->completion;
3900       return pid;
3901     }
3902
3903     /* child that already terminated? */
3904
3905     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3906         if (closed_list[j].pid == pid) {
3907             if (statusp) *statusp = closed_list[j].completion;
3908             return pid;
3909         }
3910     }
3911
3912     /* fall through if this child is not one of our own pipe children */
3913
3914 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3915
3916       /* waitpid() became available in the CRTL as of VMS 7.0, but only
3917        * in 7.2 did we get a version that fills in the VMS completion
3918        * status as Perl has always tried to do.
3919        */
3920
3921       sts = __vms_waitpid( pid, statusp, flags );
3922
3923       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3924          return sts;
3925
3926       /* If the real waitpid tells us the child does not exist, we
3927        * fall through here to implement waiting for a child that
3928        * was created by some means other than exec() (say, spawned
3929        * from DCL) or to wait for a process that is not a subprocess
3930        * of the current process.
3931        */
3932
3933 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3934
3935     {
3936       $DESCRIPTOR(intdsc,"0 00:00:01");
3937       unsigned long int ownercode = JPI$_OWNER, ownerpid;
3938       unsigned long int pidcode = JPI$_PID, mypid;
3939       unsigned long int interval[2];
3940       unsigned int jpi_iosb[2];
3941       struct itmlst_3 jpilist[2] = {
3942           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
3943           {                      0,         0,                 0, 0}
3944       };
3945
3946       if (pid <= 0) {
3947         /* Sorry folks, we don't presently implement rooting around for
3948            the first child we can find, and we definitely don't want to
3949            pass a pid of -1 to $getjpi, where it is a wildcard operation.
3950          */
3951         set_errno(ENOTSUP);
3952         return -1;
3953       }
3954
3955       /* Get the owner of the child so I can warn if it's not mine. If the
3956        * process doesn't exist or I don't have the privs to look at it,
3957        * I can go home early.
3958        */
3959       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3960       if (sts & 1) sts = jpi_iosb[0];
3961       if (!(sts & 1)) {
3962         switch (sts) {
3963             case SS$_NONEXPR:
3964                 set_errno(ECHILD);
3965                 break;
3966             case SS$_NOPRIV:
3967                 set_errno(EACCES);
3968                 break;
3969             default:
3970                 _ckvmssts(sts);
3971         }
3972         set_vaxc_errno(sts);
3973         return -1;
3974       }
3975
3976       if (ckWARN(WARN_EXEC)) {
3977         /* remind folks they are asking for non-standard waitpid behavior */
3978         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3979         if (ownerpid != mypid)
3980           Perl_warner(aTHX_ packWARN(WARN_EXEC),
3981                       "waitpid: process %x is not a child of process %x",
3982                       pid,mypid);
3983       }
3984
3985       /* simply check on it once a second until it's not there anymore. */
3986
3987       _ckvmssts(sys$bintim(&intdsc,interval));
3988       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3989             _ckvmssts(sys$schdwk(0,0,interval,0));
3990             _ckvmssts(sys$hiber());
3991       }
3992       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3993
3994       _ckvmssts(sts);
3995       return pid;
3996     }
3997 }  /* end of waitpid() */
3998 /*}}}*/
3999 /*}}}*/
4000 /*}}}*/
4001
4002 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4003 char *
4004 my_gconvert(double val, int ndig, int trail, char *buf)
4005 {
4006   static char __gcvtbuf[DBL_DIG+1];
4007   char *loc;
4008
4009   loc = buf ? buf : __gcvtbuf;
4010
4011 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4012   if (val < 1) {
4013     sprintf(loc,"%.*g",ndig,val);
4014     return loc;
4015   }
4016 #endif
4017
4018   if (val) {
4019     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4020     return gcvt(val,ndig,loc);
4021   }
4022   else {
4023     loc[0] = '0'; loc[1] = '\0';
4024     return loc;
4025   }
4026
4027 }
4028 /*}}}*/
4029
4030 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4031 static int rms_free_search_context(struct FAB * fab)
4032 {
4033 struct NAM * nam;
4034
4035     nam = fab->fab$l_nam;
4036     nam->nam$b_nop |= NAM$M_SYNCHK;
4037     nam->nam$l_rlf = NULL;
4038     fab->fab$b_dns = 0;
4039     return sys$parse(fab, NULL, NULL);
4040 }
4041
4042 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4043 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4044 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4045 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4046 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4047 #define rms_nam_esll(nam) nam.nam$b_esl
4048 #define rms_nam_esl(nam) nam.nam$b_esl
4049 #define rms_nam_name(nam) nam.nam$l_name
4050 #define rms_nam_namel(nam) nam.nam$l_name
4051 #define rms_nam_type(nam) nam.nam$l_type
4052 #define rms_nam_typel(nam) nam.nam$l_type
4053 #define rms_nam_ver(nam) nam.nam$l_ver
4054 #define rms_nam_verl(nam) nam.nam$l_ver
4055 #define rms_nam_rsll(nam) nam.nam$b_rsl
4056 #define rms_nam_rsl(nam) nam.nam$b_rsl
4057 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4058 #define rms_set_fna(fab, nam, name, size) \
4059         fab.fab$b_fns = size; fab.fab$l_fna = name;
4060 #define rms_get_fna(fab, nam) fab.fab$l_fna
4061 #define rms_set_dna(fab, nam, name, size) \
4062         fab.fab$b_dns = size; fab.fab$l_dna = name;
4063 #define rms_nam_dns(fab, nam) fab.fab$b_dns;
4064 #define rms_set_esa(fab, nam, name, size) \
4065         nam.nam$b_ess = size; nam.nam$l_esa = name;
4066 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4067         nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
4068 #define rms_set_rsa(nam, name, size) \
4069         nam.nam$l_rsa = name; nam.nam$b_rss = size;
4070 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4071         nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
4072
4073 #else
4074 static int rms_free_search_context(struct FAB * fab)
4075 {
4076 struct NAML * nam;
4077
4078     nam = fab->fab$l_naml;
4079     nam->naml$b_nop |= NAM$M_SYNCHK;
4080     nam->naml$l_rlf = NULL;
4081     nam->naml$l_long_defname_size = 0;
4082
4083     fab->fab$b_dns = 0;
4084     return sys$parse(fab, NULL, NULL);
4085 }
4086
4087 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4088 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4089 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4090 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4091 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4092 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4093 #define rms_nam_esl(nam) nam.naml$b_esl
4094 #define rms_nam_name(nam) nam.naml$l_name
4095 #define rms_nam_namel(nam) nam.naml$l_long_name
4096 #define rms_nam_type(nam) nam.naml$l_type
4097 #define rms_nam_typel(nam) nam.naml$l_long_type
4098 #define rms_nam_ver(nam) nam.naml$l_ver
4099 #define rms_nam_verl(nam) nam.naml$l_long_ver
4100 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4101 #define rms_nam_rsl(nam) nam.naml$b_rsl
4102 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4103 #define rms_set_fna(fab, nam, name, size) \
4104         fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4105         nam.naml$l_long_filename_size = size; \
4106         nam.naml$l_long_filename = name
4107 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4108 #define rms_set_dna(fab, nam, name, size) \
4109         fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4110         nam.naml$l_long_defname_size = size; \
4111         nam.naml$l_long_defname = name
4112 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4113 #define rms_set_esa(fab, nam, name, size) \
4114         nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4115         nam.naml$l_long_expand_alloc = size; \
4116         nam.naml$l_long_expand = name
4117 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4118         nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4119         nam.naml$l_long_expand = l_name; \
4120         nam.naml$l_long_expand_alloc = l_size;
4121 #define rms_set_rsa(nam, name, size) \
4122         nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4123         nam.naml$l_long_result = name; \
4124         nam.naml$l_long_result_alloc = size;
4125 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4126         nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4127         nam.naml$l_long_result = l_name; \
4128         nam.naml$l_long_result_alloc = l_size;
4129
4130 #endif
4131
4132
4133 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4134 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4135  * to expand file specification.  Allows for a single default file
4136  * specification and a simple mask of options.  If outbuf is non-NULL,
4137  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4138  * the resultant file specification is placed.  If outbuf is NULL, the
4139  * resultant file specification is placed into a static buffer.
4140  * The third argument, if non-NULL, is taken to be a default file
4141  * specification string.  The fourth argument is unused at present.
4142  * rmesexpand() returns the address of the resultant string if
4143  * successful, and NULL on error.
4144  *
4145  * New functionality for previously unused opts value:
4146  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4147  */
4148 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
4149
4150 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4151 /* ODS-2 only version */
4152 static char *
4153 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4154 {
4155   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
4156   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
4157   char esa[NAM$C_MAXRSS+1], *cp, *out = NULL;
4158   struct FAB myfab = cc$rms_fab;
4159   struct NAM mynam = cc$rms_nam;
4160   STRLEN speclen;
4161   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4162   int sts;
4163
4164   if (!filespec || !*filespec) {
4165     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4166     return NULL;
4167   }
4168   if (!outbuf) {
4169     if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
4170     else    outbuf = __rmsexpand_retbuf;
4171   }
4172   isunix = is_unix_filespec(filespec);
4173   if (isunix) {
4174     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4175         if (out)
4176            Safefree(out);
4177         return NULL;
4178     }
4179     filespec = vmsfspec;
4180   }
4181
4182   myfab.fab$l_fna = (char *)filespec;  /* cast ok for read only pointer */
4183   myfab.fab$b_fns = strlen(filespec);
4184   myfab.fab$l_nam = &mynam;
4185
4186   if (defspec && *defspec) {
4187     if (strchr(defspec,'/') != NULL) {
4188       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4189         if (out)
4190            Safefree(out);
4191         return NULL;
4192       }
4193       defspec = tmpfspec;
4194     }
4195     myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
4196     myfab.fab$b_dns = strlen(defspec);
4197   }
4198
4199   mynam.nam$l_esa = esa;
4200   mynam.nam$b_ess = NAM$C_MAXRSS;
4201   mynam.nam$l_rsa = outbuf;
4202   mynam.nam$b_rss = NAM$C_MAXRSS;
4203
4204 #ifdef NAM$M_NO_SHORT_UPCASE
4205   if (decc_efs_case_preserve)
4206     mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4207 #endif
4208
4209   retsts = sys$parse(&myfab,0,0);
4210   if (!(retsts & 1)) {
4211     mynam.nam$b_nop |= NAM$M_SYNCHK;
4212     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4213       retsts = sys$parse(&myfab,0,0);
4214       if (retsts & 1) goto expanded;
4215     }
4216     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
4217     sts = sys$parse(&myfab,0,0);  /* Free search context */
4218     if (out) Safefree(out);
4219     set_vaxc_errno(retsts);
4220     if      (retsts == RMS$_PRV) set_errno(EACCES);
4221     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4222     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4223     else                         set_errno(EVMSERR);
4224     return NULL;
4225   }
4226   retsts = sys$search(&myfab,0,0);
4227   if (!(retsts & 1) && retsts != RMS$_FNF) {
4228     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4229     myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
4230     if (out) Safefree(out);
4231     set_vaxc_errno(retsts);
4232     if      (retsts == RMS$_PRV) set_errno(EACCES);
4233     else                         set_errno(EVMSERR);
4234     return NULL;
4235   }
4236
4237   /* If the input filespec contained any lowercase characters,
4238    * downcase the result for compatibility with Unix-minded code. */
4239   expanded:
4240   if (!decc_efs_case_preserve) {
4241     for (out = myfab.fab$l_fna; *out; out++)
4242       if (islower(*out)) { haslower = 1; break; }
4243   }
4244   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
4245   else                 { out = esa;    speclen = mynam.nam$b_esl; }
4246   out[speclen] = 0;
4247   /* Trim off null fields added by $PARSE
4248    * If type > 1 char, must have been specified in original or default spec
4249    * (not true for version; $SEARCH may have added version of existing file).
4250    */
4251   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
4252   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
4253              (mynam.nam$l_ver - mynam.nam$l_type == 1);
4254   if (trimver || trimtype) {
4255     if (defspec && *defspec) {
4256       char defesa[NAM$C_MAXRSS];
4257       struct FAB deffab = cc$rms_fab;
4258       struct NAM defnam = cc$rms_nam;
4259
4260       deffab.fab$l_nam = &defnam;
4261       /* cast below ok for read only pointer */
4262       deffab.fab$l_fna = (char *)defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
4263       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = NAM$C_MAXRSS;
4264       defnam.nam$b_nop = NAM$M_SYNCHK;
4265 #ifdef NAM$M_NO_SHORT_UPCASE
4266       if (decc_efs_case_preserve)
4267         defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4268 #endif
4269       if (sys$parse(&deffab,0,0) & 1) {
4270         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
4271         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4272       }
4273     }
4274     if (trimver) {
4275       if (*mynam.nam$l_ver != '\"')
4276         speclen = mynam.nam$l_ver - out;
4277     }
4278     if (trimtype) {
4279       /* If we didn't already trim version, copy down */
4280       if (speclen > mynam.nam$l_ver - out)
4281         memmove(mynam.nam$l_type, mynam.nam$l_ver,
4282                speclen - (mynam.nam$l_ver - out));
4283       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4284     }
4285   }
4286   /* If we just had a directory spec on input, $PARSE "helpfully"
4287    * adds an empty name and type for us */
4288   if (mynam.nam$l_name == mynam.nam$l_type &&
4289       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
4290       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4291     speclen = mynam.nam$l_name - out;
4292
4293   /* Posix format specifications must have matching quotes */
4294   if (speclen < NAM$C_MAXRSS) {
4295     if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4296       if ((speclen > 1) && (out[speclen-1] != '\"')) {
4297         out[speclen] = '\"';
4298         speclen++;
4299       }
4300     }
4301   }
4302
4303   out[speclen] = '\0';
4304   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4305
4306   /* Have we been working with an expanded, but not resultant, spec? */
4307   /* Also, convert back to Unix syntax if necessary. */
4308   if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4309     isunix = 0;
4310
4311   if (!mynam.nam$b_rsl) {
4312     if (isunix) {
4313       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4314     }
4315     else strcpy(outbuf,esa);
4316   }
4317   else if (isunix) {
4318     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4319     strcpy(outbuf,tmpfspec);
4320   }
4321   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4322   mynam.nam$l_rsa = NULL;
4323   mynam.nam$b_rss = 0;
4324   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);  /* Free search context */
4325   return outbuf;
4326 }
4327 #else
4328 /* ODS-5 supporting routine */
4329 static char *
4330 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4331 {
4332   static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4333   char * vmsfspec, *tmpfspec;
4334   char * esa, *cp, *out = NULL;
4335   char * tbuf;
4336   char * esal;
4337   char * outbufl;
4338   struct FAB myfab = cc$rms_fab;
4339   rms_setup_nam(mynam);
4340   STRLEN speclen;
4341   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4342   int sts;
4343
4344   if (!filespec || !*filespec) {
4345     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4346     return NULL;
4347   }
4348   if (!outbuf) {
4349     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4350     else    outbuf = __rmsexpand_retbuf;
4351   }
4352
4353   vmsfspec = NULL;
4354   tmpfspec = NULL;
4355   outbufl = NULL;
4356   isunix = is_unix_filespec(filespec);
4357   if (isunix) {
4358     vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4359     if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4360     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4361         PerlMem_free(vmsfspec);
4362         if (out)
4363            Safefree(out);
4364         return NULL;
4365     }
4366     filespec = vmsfspec;
4367
4368      /* Unless we are forcing to VMS format, a UNIX input means
4369       * UNIX output, and that requires long names to be used
4370       */
4371     if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4372         opts |= PERL_RMSEXPAND_M_LONG;
4373     else {
4374         isunix = 0;
4375     }
4376   }
4377
4378   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4379   rms_bind_fab_nam(myfab, mynam);
4380
4381   if (defspec && *defspec) {
4382     int t_isunix;
4383     t_isunix = is_unix_filespec(defspec);
4384     if (t_isunix) {
4385       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4386       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4387       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4388         PerlMem_free(tmpfspec);
4389         if (vmsfspec != NULL)
4390             PerlMem_free(vmsfspec);
4391         if (out)
4392            Safefree(out);
4393         return NULL;
4394       }
4395       defspec = tmpfspec;
4396     }
4397     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4398   }
4399
4400   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4401   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4402 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4403   esal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4404   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4405 #endif
4406   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
4407
4408   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4409     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4410   }
4411   else {
4412 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4413     outbufl = PerlMem_malloc(VMS_MAXRSS);
4414     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4415     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4416 #else
4417     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4418 #endif
4419   }
4420
4421 #ifdef NAM$M_NO_SHORT_UPCASE
4422   if (decc_efs_case_preserve)
4423     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4424 #endif
4425
4426   /* First attempt to parse as an existing file */
4427   retsts = sys$parse(&myfab,0,0);
4428   if (!(retsts & STS$K_SUCCESS)) {
4429
4430     /* Could not find the file, try as syntax only if error is not fatal */
4431     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4432     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4433       retsts = sys$parse(&myfab,0,0);
4434       if (retsts & STS$K_SUCCESS) goto expanded;
4435     }
4436
4437      /* Still could not parse the file specification */
4438     /*----------------------------------------------*/
4439     sts = rms_free_search_context(&myfab); /* Free search context */
4440     if (out) Safefree(out);
4441     if (tmpfspec != NULL)
4442         PerlMem_free(tmpfspec);
4443     if (vmsfspec != NULL)
4444         PerlMem_free(vmsfspec);
4445     if (outbufl != NULL)
4446         PerlMem_free(outbufl);
4447     PerlMem_free(esa);
4448     PerlMem_free(esal);
4449     set_vaxc_errno(retsts);
4450     if      (retsts == RMS$_PRV) set_errno(EACCES);
4451     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4452     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4453     else                         set_errno(EVMSERR);
4454     return NULL;
4455   }
4456   retsts = sys$search(&myfab,0,0);
4457   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
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                         set_errno(EVMSERR);
4471     return NULL;
4472   }
4473
4474   /* If the input filespec contained any lowercase characters,
4475    * downcase the result for compatibility with Unix-minded code. */
4476   expanded:
4477   if (!decc_efs_case_preserve) {
4478     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4479       if (islower(*tbuf)) { haslower = 1; break; }
4480   }
4481
4482    /* Is a long or a short name expected */
4483   /*------------------------------------*/
4484   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4485     if (rms_nam_rsll(mynam)) {
4486         tbuf = outbuf;
4487         speclen = rms_nam_rsll(mynam);
4488     }
4489     else {
4490         tbuf = esal; /* Not esa */
4491         speclen = rms_nam_esll(mynam);
4492     }
4493   }
4494   else {
4495     if (rms_nam_rsl(mynam)) {
4496         tbuf = outbuf;
4497         speclen = rms_nam_rsl(mynam);
4498     }
4499     else {
4500         tbuf = esa; /* Not esal */
4501         speclen = rms_nam_esl(mynam);
4502     }
4503   }
4504   tbuf[speclen] = '\0';
4505
4506   /* Trim off null fields added by $PARSE
4507    * If type > 1 char, must have been specified in original or default spec
4508    * (not true for version; $SEARCH may have added version of existing file).
4509    */
4510   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4511   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4512     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4513              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4514   }
4515   else {
4516     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4517              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4518   }
4519   if (trimver || trimtype) {
4520     if (defspec && *defspec) {
4521       char *defesal = NULL;
4522       defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4523       if (defesal != NULL) {
4524         struct FAB deffab = cc$rms_fab;
4525         rms_setup_nam(defnam);
4526
4527         rms_bind_fab_nam(deffab, defnam);
4528
4529         /* Cast ok */
4530         rms_set_fna
4531             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4532
4533         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4534
4535         rms_clear_nam_nop(defnam);
4536         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4537 #ifdef NAM$M_NO_SHORT_UPCASE
4538         if (decc_efs_case_preserve)
4539           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4540 #endif
4541         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4542           if (trimver) {
4543              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4544           }
4545           if (trimtype) {
4546             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4547           }
4548         }
4549         PerlMem_free(defesal);
4550       }
4551     }
4552     if (trimver) {
4553       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4554         if (*(rms_nam_verl(mynam)) != '\"')
4555           speclen = rms_nam_verl(mynam) - tbuf;
4556       }
4557       else {
4558         if (*(rms_nam_ver(mynam)) != '\"')
4559           speclen = rms_nam_ver(mynam) - tbuf;
4560       }
4561     }
4562     if (trimtype) {
4563       /* If we didn't already trim version, copy down */
4564       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4565         if (speclen > rms_nam_verl(mynam) - tbuf)
4566           memmove
4567            (rms_nam_typel(mynam),
4568             rms_nam_verl(mynam),
4569             speclen - (rms_nam_verl(mynam) - tbuf));
4570           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4571       }
4572       else {
4573         if (speclen > rms_nam_ver(mynam) - tbuf)
4574           memmove
4575            (rms_nam_type(mynam),
4576             rms_nam_ver(mynam),
4577             speclen - (rms_nam_ver(mynam) - tbuf));
4578           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4579       }
4580     }
4581   }
4582
4583    /* Done with these copies of the input files */
4584   /*-------------------------------------------*/
4585   if (vmsfspec != NULL)
4586         PerlMem_free(vmsfspec);
4587   if (tmpfspec != NULL)
4588         PerlMem_free(tmpfspec);
4589
4590   /* If we just had a directory spec on input, $PARSE "helpfully"
4591    * adds an empty name and type for us */
4592   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4593     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4594         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
4595         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4596       speclen = rms_nam_namel(mynam) - tbuf;
4597   }
4598   else {
4599     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4600         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
4601         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4602       speclen = rms_nam_name(mynam) - tbuf;
4603   }
4604
4605   /* Posix format specifications must have matching quotes */
4606   if (speclen < (VMS_MAXRSS - 1)) {
4607     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4608       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4609         tbuf[speclen] = '\"';
4610         speclen++;
4611       }
4612     }
4613   }
4614   tbuf[speclen] = '\0';
4615   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4616
4617   /* Have we been working with an expanded, but not resultant, spec? */
4618   /* Also, convert back to Unix syntax if necessary. */
4619
4620   if (!rms_nam_rsll(mynam)) {
4621     if (isunix) {
4622       if (do_tounixspec(esa,outbuf,0) == NULL) {
4623         if (out) Safefree(out);
4624         PerlMem_free(esal);
4625         PerlMem_free(esa);
4626         if (outbufl != NULL)
4627             PerlMem_free(outbufl);
4628         return NULL;
4629       }
4630     }
4631     else strcpy(outbuf,esa);
4632   }
4633   else if (isunix) {
4634     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4635     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4636     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4637         if (out) Safefree(out);
4638         PerlMem_free(esa);
4639         PerlMem_free(esal);
4640         PerlMem_free(tmpfspec);
4641         if (outbufl != NULL)
4642             PerlMem_free(outbufl);
4643         return NULL;
4644     }
4645     strcpy(outbuf,tmpfspec);
4646     PerlMem_free(tmpfspec);
4647   }
4648
4649   rms_set_rsal(mynam, NULL, 0, NULL, 0);
4650   sts = rms_free_search_context(&myfab); /* Free search context */
4651   PerlMem_free(esa);
4652   PerlMem_free(esal);
4653   if (outbufl != NULL)
4654      PerlMem_free(outbufl);
4655   return outbuf;
4656 }
4657 #endif
4658 /*}}}*/
4659 /* External entry points */
4660 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4661 { return do_rmsexpand(spec,buf,0,def,opt); }
4662 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4663 { return do_rmsexpand(spec,buf,1,def,opt); }
4664
4665
4666 /*
4667 ** The following routines are provided to make life easier when
4668 ** converting among VMS-style and Unix-style directory specifications.
4669 ** All will take input specifications in either VMS or Unix syntax. On
4670 ** failure, all return NULL.  If successful, the routines listed below
4671 ** return a pointer to a buffer containing the appropriately
4672 ** reformatted spec (and, therefore, subsequent calls to that routine
4673 ** will clobber the result), while the routines of the same names with
4674 ** a _ts suffix appended will return a pointer to a mallocd string
4675 ** containing the appropriately reformatted spec.
4676 ** In all cases, only explicit syntax is altered; no check is made that
4677 ** the resulting string is valid or that the directory in question
4678 ** actually exists.
4679 **
4680 **   fileify_dirspec() - convert a directory spec into the name of the
4681 **     directory file (i.e. what you can stat() to see if it's a dir).
4682 **     The style (VMS or Unix) of the result is the same as the style
4683 **     of the parameter passed in.
4684 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4685 **     what you prepend to a filename to indicate what directory it's in).
4686 **     The style (VMS or Unix) of the result is the same as the style
4687 **     of the parameter passed in.
4688 **   tounixpath() - convert a directory spec into a Unix-style path.
4689 **   tovmspath() - convert a directory spec into a VMS-style path.
4690 **   tounixspec() - convert any file spec into a Unix-style file spec.
4691 **   tovmsspec() - convert any file spec into a VMS-style spec.
4692 **
4693 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4694 ** Permission is given to distribute this code as part of the Perl
4695 ** standard distribution under the terms of the GNU General Public
4696 ** License or the Perl Artistic License.  Copies of each may be
4697 ** found in the Perl standard distribution.
4698  */
4699
4700 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4701 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4702 {
4703     static char __fileify_retbuf[VMS_MAXRSS];
4704     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4705     char *retspec, *cp1, *cp2, *lastdir;
4706     char *trndir, *vmsdir;
4707     unsigned short int trnlnm_iter_count;
4708     int sts;
4709
4710     if (!dir || !*dir) {
4711       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4712     }
4713     dirlen = strlen(dir);
4714     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4715     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4716       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4717         dir = "/sys$disk";
4718         dirlen = 9;
4719       }
4720       else
4721         dirlen = 1;
4722     }
4723     if (dirlen > (VMS_MAXRSS - 1)) {
4724       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4725       return NULL;
4726     }
4727     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4728     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4729     if (!strpbrk(dir+1,"/]>:")  &&
4730         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4731       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4732       trnlnm_iter_count = 0;
4733       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4734         trnlnm_iter_count++;
4735         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4736       }
4737       dirlen = strlen(trndir);
4738     }
4739     else {
4740       strncpy(trndir,dir,dirlen);
4741       trndir[dirlen] = '\0';
4742     }
4743
4744     /* At this point we are done with *dir and use *trndir which is a
4745      * copy that can be modified.  *dir must not be modified.
4746      */
4747
4748     /* If we were handed a rooted logical name or spec, treat it like a
4749      * simple directory, so that
4750      *    $ Define myroot dev:[dir.]
4751      *    ... do_fileify_dirspec("myroot",buf,1) ...
4752      * does something useful.
4753      */
4754     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4755       trndir[--dirlen] = '\0';
4756       trndir[dirlen-1] = ']';
4757     }
4758     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4759       trndir[--dirlen] = '\0';
4760       trndir[dirlen-1] = '>';
4761     }
4762
4763     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4764       /* If we've got an explicit filename, we can just shuffle the string. */
4765       if (*(cp1+1)) hasfilename = 1;
4766       /* Similarly, we can just back up a level if we've got multiple levels
4767          of explicit directories in a VMS spec which ends with directories. */
4768       else {
4769         for (cp2 = cp1; cp2 > trndir; cp2--) {
4770           if (*cp2 == '.') {
4771             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4772 /* fix-me, can not scan EFS file specs backward like this */
4773               *cp2 = *cp1; *cp1 = '\0';
4774               hasfilename = 1;
4775               break;
4776             }
4777           }
4778           if (*cp2 == '[' || *cp2 == '<') break;
4779         }
4780       }
4781     }
4782
4783     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4784     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4785     cp1 = strpbrk(trndir,"]:>");
4786     if (hasfilename || !cp1) { /* Unix-style path or filename */
4787       if (trndir[0] == '.') {
4788         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4789           PerlMem_free(trndir);
4790           PerlMem_free(vmsdir);
4791           return do_fileify_dirspec("[]",buf,ts);
4792         }
4793         else if (trndir[1] == '.' &&
4794                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4795           PerlMem_free(trndir);
4796           PerlMem_free(vmsdir);
4797           return do_fileify_dirspec("[-]",buf,ts);
4798         }
4799       }
4800       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4801         dirlen -= 1;                 /* to last element */
4802         lastdir = strrchr(trndir,'/');
4803       }
4804       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4805         /* If we have "/." or "/..", VMSify it and let the VMS code
4806          * below expand it, rather than repeating the code to handle
4807          * relative components of a filespec here */
4808         do {
4809           if (*(cp1+2) == '.') cp1++;
4810           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4811             char * ret_chr;
4812             if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4813                 PerlMem_free(trndir);
4814                 PerlMem_free(vmsdir);
4815                 return NULL;
4816             }
4817             if (strchr(vmsdir,'/') != NULL) {
4818               /* If do_tovmsspec() returned it, it must have VMS syntax
4819                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
4820                * the time to check this here only so we avoid a recursion
4821                * loop; otherwise, gigo.
4822                */
4823               PerlMem_free(trndir);
4824               PerlMem_free(vmsdir);
4825               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
4826               return NULL;
4827             }
4828             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4829                 PerlMem_free(trndir);
4830                 PerlMem_free(vmsdir);
4831                 return NULL;
4832             }
4833             ret_chr = do_tounixspec(trndir,buf,ts);
4834             PerlMem_free(trndir);
4835             PerlMem_free(vmsdir);
4836             return ret_chr;
4837           }
4838           cp1++;
4839         } while ((cp1 = strstr(cp1,"/.")) != NULL);
4840         lastdir = strrchr(trndir,'/');
4841       }
4842       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4843         char * ret_chr;
4844         /* Ditto for specs that end in an MFD -- let the VMS code
4845          * figure out whether it's a real device or a rooted logical. */
4846
4847         /* This should not happen any more.  Allowing the fake /000000
4848          * in a UNIX pathname causes all sorts of problems when trying
4849          * to run in UNIX emulation.  So the VMS to UNIX conversions
4850          * now remove the fake /000000 directories.
4851          */
4852
4853         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4854         if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4855             PerlMem_free(trndir);
4856             PerlMem_free(vmsdir);
4857             return NULL;
4858         }
4859         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4860             PerlMem_free(trndir);
4861             PerlMem_free(vmsdir);
4862             return NULL;
4863         }
4864         ret_chr = do_tounixspec(trndir,buf,ts);
4865         PerlMem_free(trndir);
4866         PerlMem_free(vmsdir);
4867         return ret_chr;
4868       }
4869       else {
4870
4871         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4872              !(lastdir = cp1 = strrchr(trndir,']')) &&
4873              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4874         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
4875           int ver; char *cp3;
4876
4877           /* For EFS or ODS-5 look for the last dot */
4878           if (decc_efs_charset) {
4879               cp2 = strrchr(cp1,'.');
4880           }
4881           if (vms_process_case_tolerant) {
4882               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4883                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4884                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4885                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4886                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4887                             (ver || *cp3)))))) {
4888                   PerlMem_free(trndir);
4889                   PerlMem_free(vmsdir);
4890                   set_errno(ENOTDIR);
4891                   set_vaxc_errno(RMS$_DIR);
4892                   return NULL;
4893               }
4894           }
4895           else {
4896               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4897                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4898                   !*(cp2+3) || *(cp2+3) != 'R' ||
4899                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4900                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4901                             (ver || *cp3)))))) {
4902                  PerlMem_free(trndir);
4903                  PerlMem_free(vmsdir);
4904                  set_errno(ENOTDIR);
4905                  set_vaxc_errno(RMS$_DIR);
4906                  return NULL;
4907               }
4908           }
4909           dirlen = cp2 - trndir;
4910         }
4911       }
4912
4913       retlen = dirlen + 6;
4914       if (buf) retspec = buf;
4915       else if (ts) Newx(retspec,retlen+1,char);
4916       else retspec = __fileify_retbuf;
4917       memcpy(retspec,trndir,dirlen);
4918       retspec[dirlen] = '\0';
4919
4920       /* We've picked up everything up to the directory file name.
4921          Now just add the type and version, and we're set. */
4922       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4923         strcat(retspec,".dir;1");
4924       else
4925         strcat(retspec,".DIR;1");
4926       PerlMem_free(trndir);
4927       PerlMem_free(vmsdir);
4928       return retspec;
4929     }
4930     else {  /* VMS-style directory spec */
4931
4932       char *esa, term, *cp;
4933       unsigned long int sts, cmplen, haslower = 0;
4934       unsigned int nam_fnb;
4935       char * nam_type;
4936       struct FAB dirfab = cc$rms_fab;
4937       rms_setup_nam(savnam);
4938       rms_setup_nam(dirnam);
4939
4940       esa = PerlMem_malloc(VMS_MAXRSS + 1);
4941       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4942       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4943       rms_bind_fab_nam(dirfab, dirnam);
4944       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4945       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4946 #ifdef NAM$M_NO_SHORT_UPCASE
4947       if (decc_efs_case_preserve)
4948         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4949 #endif
4950
4951       for (cp = trndir; *cp; cp++)
4952         if (islower(*cp)) { haslower = 1; break; }
4953       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4954         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4955           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4956           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4957         }
4958         if (!sts) {
4959           PerlMem_free(esa);
4960           PerlMem_free(trndir);
4961           PerlMem_free(vmsdir);
4962           set_errno(EVMSERR);
4963           set_vaxc_errno(dirfab.fab$l_sts);
4964           return NULL;
4965         }
4966       }
4967       else {
4968         savnam = dirnam;
4969         /* Does the file really exist? */
4970         if (sys$search(&dirfab)& STS$K_SUCCESS) {
4971           /* Yes; fake the fnb bits so we'll check type below */
4972         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4973         }
4974         else { /* No; just work with potential name */
4975           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4976           else {
4977             int fab_sts;
4978             fab_sts = dirfab.fab$l_sts;
4979             sts = rms_free_search_context(&dirfab);
4980             PerlMem_free(esa);
4981             PerlMem_free(trndir);
4982             PerlMem_free(vmsdir);
4983             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
4984             return NULL;
4985           }
4986         }
4987       }
4988       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4989         cp1 = strchr(esa,']');
4990         if (!cp1) cp1 = strchr(esa,'>');
4991         if (cp1) {  /* Should always be true */
4992           rms_nam_esll(dirnam) -= cp1 - esa - 1;
4993           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
4994         }
4995       }
4996       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
4997         /* Yep; check version while we're at it, if it's there. */
4998         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
4999         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5000           /* Something other than .DIR[;1].  Bzzt. */
5001           sts = rms_free_search_context(&dirfab);
5002           PerlMem_free(esa);
5003           PerlMem_free(trndir);
5004           PerlMem_free(vmsdir);
5005           set_errno(ENOTDIR);
5006           set_vaxc_errno(RMS$_DIR);
5007           return NULL;
5008         }
5009       }
5010       esa[rms_nam_esll(dirnam)] = '\0';
5011       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5012         /* They provided at least the name; we added the type, if necessary, */
5013         if (buf) retspec = buf;                            /* in sys$parse() */
5014         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5015         else retspec = __fileify_retbuf;
5016         strcpy(retspec,esa);
5017         sts = rms_free_search_context(&dirfab);
5018         PerlMem_free(trndir);
5019         PerlMem_free(esa);
5020         PerlMem_free(vmsdir);
5021         return retspec;
5022       }
5023       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5024         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5025         *cp1 = '\0';
5026         rms_nam_esll(dirnam) -= 9;
5027       }
5028       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5029       if (cp1 == NULL) { /* should never happen */
5030         sts = rms_free_search_context(&dirfab);
5031         PerlMem_free(trndir);
5032         PerlMem_free(esa);
5033         PerlMem_free(vmsdir);
5034         return NULL;
5035       }
5036       term = *cp1;
5037       *cp1 = '\0';
5038       retlen = strlen(esa);
5039       cp1 = strrchr(esa,'.');
5040       /* ODS-5 directory specifications can have extra "." in them. */
5041       /* Fix-me, can not scan EFS file specifications backwards */
5042       while (cp1 != NULL) {
5043         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5044           break;
5045         else {
5046            cp1--;
5047            while ((cp1 > esa) && (*cp1 != '.'))
5048              cp1--;
5049         }
5050         if (cp1 == esa)
5051           cp1 = NULL;
5052       }
5053
5054       if ((cp1) != NULL) {
5055         /* There's more than one directory in the path.  Just roll back. */
5056         *cp1 = term;
5057         if (buf) retspec = buf;
5058         else if (ts) Newx(retspec,retlen+7,char);
5059         else retspec = __fileify_retbuf;
5060         strcpy(retspec,esa);
5061       }
5062       else {
5063         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5064           /* Go back and expand rooted logical name */
5065           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5066 #ifdef NAM$M_NO_SHORT_UPCASE
5067           if (decc_efs_case_preserve)
5068             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5069 #endif
5070           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5071             sts = rms_free_search_context(&dirfab);
5072             PerlMem_free(esa);
5073             PerlMem_free(trndir);
5074             PerlMem_free(vmsdir);
5075             set_errno(EVMSERR);
5076             set_vaxc_errno(dirfab.fab$l_sts);
5077             return NULL;
5078           }
5079           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5080           if (buf) retspec = buf;
5081           else if (ts) Newx(retspec,retlen+16,char);
5082           else retspec = __fileify_retbuf;
5083           cp1 = strstr(esa,"][");
5084           if (!cp1) cp1 = strstr(esa,"]<");
5085           dirlen = cp1 - esa;
5086           memcpy(retspec,esa,dirlen);
5087           if (!strncmp(cp1+2,"000000]",7)) {
5088             retspec[dirlen-1] = '\0';
5089             /* fix-me Not full ODS-5, just extra dots in directories for now */
5090             cp1 = retspec + dirlen - 1;
5091             while (cp1 > retspec)
5092             {
5093               if (*cp1 == '[')
5094                 break;
5095               if (*cp1 == '.') {
5096                 if (*(cp1-1) != '^')
5097                   break;
5098               }
5099               cp1--;
5100             }
5101             if (*cp1 == '.') *cp1 = ']';
5102             else {
5103               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5104               memmove(cp1+1,"000000]",7);
5105             }
5106           }
5107           else {
5108             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5109             retspec[retlen] = '\0';
5110             /* Convert last '.' to ']' */
5111             cp1 = retspec+retlen-1;
5112             while (*cp != '[') {
5113               cp1--;
5114               if (*cp1 == '.') {
5115                 /* Do not trip on extra dots in ODS-5 directories */
5116                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5117                 break;
5118               }
5119             }
5120             if (*cp1 == '.') *cp1 = ']';
5121             else {
5122               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5123               memmove(cp1+1,"000000]",7);
5124             }
5125           }
5126         }
5127         else {  /* This is a top-level dir.  Add the MFD to the path. */
5128           if (buf) retspec = buf;
5129           else if (ts) Newx(retspec,retlen+16,char);
5130           else retspec = __fileify_retbuf;
5131           cp1 = esa;
5132           cp2 = retspec;
5133           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5134           strcpy(cp2,":[000000]");
5135           cp1 += 2;
5136           strcpy(cp2+9,cp1);
5137         }
5138       }
5139       sts = rms_free_search_context(&dirfab);
5140       /* We've set up the string up through the filename.  Add the
5141          type and version, and we're done. */
5142       strcat(retspec,".DIR;1");
5143
5144       /* $PARSE may have upcased filespec, so convert output to lower
5145        * case if input contained any lowercase characters. */
5146       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5147       PerlMem_free(trndir);
5148       PerlMem_free(esa);
5149       PerlMem_free(vmsdir);
5150       return retspec;
5151     }
5152 }  /* end of do_fileify_dirspec() */
5153 /*}}}*/
5154 /* External entry points */
5155 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5156 { return do_fileify_dirspec(dir,buf,0); }
5157 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5158 { return do_fileify_dirspec(dir,buf,1); }
5159
5160 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5161 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
5162 {
5163     static char __pathify_retbuf[VMS_MAXRSS];
5164     unsigned long int retlen;
5165     char *retpath, *cp1, *cp2, *trndir;
5166     unsigned short int trnlnm_iter_count;
5167     STRLEN trnlen;
5168     int sts;
5169
5170     if (!dir || !*dir) {
5171       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5172     }
5173
5174     trndir = PerlMem_malloc(VMS_MAXRSS);
5175     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5176     if (*dir) strcpy(trndir,dir);
5177     else getcwd(trndir,VMS_MAXRSS - 1);
5178
5179     trnlnm_iter_count = 0;
5180     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5181            && my_trnlnm(trndir,trndir,0)) {
5182       trnlnm_iter_count++;
5183       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5184       trnlen = strlen(trndir);
5185
5186       /* Trap simple rooted lnms, and return lnm:[000000] */
5187       if (!strcmp(trndir+trnlen-2,".]")) {
5188         if (buf) retpath = buf;
5189         else if (ts) Newx(retpath,strlen(dir)+10,char);
5190         else retpath = __pathify_retbuf;
5191         strcpy(retpath,dir);
5192         strcat(retpath,":[000000]");
5193         PerlMem_free(trndir);
5194         return retpath;
5195       }
5196     }
5197
5198     /* At this point we do not work with *dir, but the copy in
5199      * *trndir that is modifiable.
5200      */
5201
5202     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5203       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5204                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5205         retlen = 2 + (*(trndir+1) != '\0');
5206       else {
5207         if ( !(cp1 = strrchr(trndir,'/')) &&
5208              !(cp1 = strrchr(trndir,']')) &&
5209              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5210         if ((cp2 = strchr(cp1,'.')) != NULL &&
5211             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5212              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5213               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5214               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5215           int ver; char *cp3;
5216
5217           /* For EFS or ODS-5 look for the last dot */
5218           if (decc_efs_charset) {
5219             cp2 = strrchr(cp1,'.');
5220           }
5221           if (vms_process_case_tolerant) {
5222               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5223                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5224                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5225                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5226                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5227                             (ver || *cp3)))))) {
5228                 PerlMem_free(trndir);
5229                 set_errno(ENOTDIR);
5230                 set_vaxc_errno(RMS$_DIR);
5231                 return NULL;
5232               }
5233           }
5234           else {
5235               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5236                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5237                   !*(cp2+3) || *(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           retlen = cp2 - trndir + 1;
5248         }
5249         else {  /* No file type present.  Treat the filename as a directory. */
5250           retlen = strlen(trndir) + 1;
5251         }
5252       }
5253       if (buf) retpath = buf;
5254       else if (ts) Newx(retpath,retlen+1,char);
5255       else retpath = __pathify_retbuf;
5256       strncpy(retpath, trndir, retlen-1);
5257       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5258         retpath[retlen-1] = '/';      /* with '/', add it. */
5259         retpath[retlen] = '\0';
5260       }
5261       else retpath[retlen-1] = '\0';
5262     }
5263     else {  /* VMS-style directory spec */
5264       char *esa, *cp;
5265       unsigned long int sts, cmplen, haslower;
5266       struct FAB dirfab = cc$rms_fab;
5267       int dirlen;
5268       rms_setup_nam(savnam);
5269       rms_setup_nam(dirnam);
5270
5271       /* If we've got an explicit filename, we can just shuffle the string. */
5272       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5273              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5274         if ((cp2 = strchr(cp1,'.')) != NULL) {
5275           int ver; char *cp3;
5276           if (vms_process_case_tolerant) {
5277               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5278                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5279                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5280                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5281                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5282                             (ver || *cp3)))))) {
5283                PerlMem_free(trndir);
5284                set_errno(ENOTDIR);
5285                set_vaxc_errno(RMS$_DIR);
5286                return NULL;
5287              }
5288           }
5289           else {
5290               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5291                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5292                   !*(cp2+3) || *(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         }
5303         else {  /* No file type, so just draw name into directory part */
5304           for (cp2 = cp1; *cp2; cp2++) ;
5305         }
5306         *cp2 = *cp1;
5307         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5308         *cp1 = '.';
5309         /* We've now got a VMS 'path'; fall through */
5310       }
5311
5312       dirlen = strlen(trndir);
5313       if (trndir[dirlen-1] == ']' ||
5314           trndir[dirlen-1] == '>' ||
5315           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5316         if (buf) retpath = buf;
5317         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5318         else retpath = __pathify_retbuf;
5319         strcpy(retpath,trndir);
5320         PerlMem_free(trndir);
5321         return retpath;
5322       }
5323       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5324       esa = PerlMem_malloc(VMS_MAXRSS);
5325       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5326       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5327       rms_bind_fab_nam(dirfab, dirnam);
5328       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5329 #ifdef NAM$M_NO_SHORT_UPCASE
5330       if (decc_efs_case_preserve)
5331           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5332 #endif
5333
5334       for (cp = trndir; *cp; cp++)
5335         if (islower(*cp)) { haslower = 1; break; }
5336
5337       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5338         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5339           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5340           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5341         }
5342         if (!sts) {
5343           PerlMem_free(trndir);
5344           PerlMem_free(esa);
5345           set_errno(EVMSERR);
5346           set_vaxc_errno(dirfab.fab$l_sts);
5347           return NULL;
5348         }
5349       }
5350       else {
5351         savnam = dirnam;
5352         /* Does the file really exist? */
5353         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5354           if (dirfab.fab$l_sts != RMS$_FNF) {
5355             int sts1;
5356             sts1 = rms_free_search_context(&dirfab);
5357             PerlMem_free(trndir);
5358             PerlMem_free(esa);
5359             set_errno(EVMSERR);
5360             set_vaxc_errno(dirfab.fab$l_sts);
5361             return NULL;
5362           }
5363           dirnam = savnam; /* No; just work with potential name */
5364         }
5365       }
5366       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5367         /* Yep; check version while we're at it, if it's there. */
5368         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5369         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5370           int sts2;
5371           /* Something other than .DIR[;1].  Bzzt. */
5372           sts2 = rms_free_search_context(&dirfab);
5373           PerlMem_free(trndir);
5374           PerlMem_free(esa);
5375           set_errno(ENOTDIR);
5376           set_vaxc_errno(RMS$_DIR);
5377           return NULL;
5378         }
5379       }
5380       /* OK, the type was fine.  Now pull any file name into the
5381          directory path. */
5382       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5383       else {
5384         cp1 = strrchr(esa,'>');
5385         *(rms_nam_typel(dirnam)) = '>';
5386       }
5387       *cp1 = '.';
5388       *(rms_nam_typel(dirnam) + 1) = '\0';
5389       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5390       if (buf) retpath = buf;
5391       else if (ts) Newx(retpath,retlen,char);
5392       else retpath = __pathify_retbuf;
5393       strcpy(retpath,esa);
5394       PerlMem_free(esa);
5395       sts = rms_free_search_context(&dirfab);
5396       /* $PARSE may have upcased filespec, so convert output to lower
5397        * case if input contained any lowercase characters. */
5398       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5399     }
5400
5401     PerlMem_free(trndir);
5402     return retpath;
5403 }  /* end of do_pathify_dirspec() */
5404 /*}}}*/
5405 /* External entry points */
5406 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5407 { return do_pathify_dirspec(dir,buf,0); }
5408 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5409 { return do_pathify_dirspec(dir,buf,1); }
5410
5411 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5412 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5413 {
5414   static char __tounixspec_retbuf[VMS_MAXRSS];
5415   char *dirend, *rslt, *cp1, *cp3, *tmp;
5416   const char *cp2;
5417   int devlen, dirlen, retlen = VMS_MAXRSS;
5418   int expand = 1; /* guarantee room for leading and trailing slashes */
5419   unsigned short int trnlnm_iter_count;
5420   int cmp_rslt;
5421
5422   if (spec == NULL) return NULL;
5423   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5424   if (buf) rslt = buf;
5425   else if (ts) {
5426     Newx(rslt, VMS_MAXRSS, char);
5427   }
5428   else rslt = __tounixspec_retbuf;
5429
5430   /* New VMS specific format needs translation
5431    * glob passes filenames with trailing '\n' and expects this preserved.
5432    */
5433   if (decc_posix_compliant_pathnames) {
5434     if (strncmp(spec, "\"^UP^", 5) == 0) {
5435       char * uspec;
5436       char *tunix;
5437       int tunix_len;
5438       int nl_flag;
5439
5440       tunix = PerlMem_malloc(VMS_MAXRSS);
5441       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5442       strcpy(tunix, spec);
5443       tunix_len = strlen(tunix);
5444       nl_flag = 0;
5445       if (tunix[tunix_len - 1] == '\n') {
5446         tunix[tunix_len - 1] = '\"';
5447         tunix[tunix_len] = '\0';
5448         tunix_len--;
5449         nl_flag = 1;
5450       }
5451       uspec = decc$translate_vms(tunix);
5452       PerlMem_free(tunix);
5453       if ((int)uspec > 0) {
5454         strcpy(rslt,uspec);
5455         if (nl_flag) {
5456           strcat(rslt,"\n");
5457         }
5458         else {
5459           /* If we can not translate it, makemaker wants as-is */
5460           strcpy(rslt, spec);
5461         }
5462         return rslt;
5463       }
5464     }
5465   }
5466
5467   cmp_rslt = 0; /* Presume VMS */
5468   cp1 = strchr(spec, '/');
5469   if (cp1 == NULL)
5470     cmp_rslt = 0;
5471
5472     /* Look for EFS ^/ */
5473     if (decc_efs_charset) {
5474       while (cp1 != NULL) {
5475         cp2 = cp1 - 1;
5476         if (*cp2 != '^') {
5477           /* Found illegal VMS, assume UNIX */
5478           cmp_rslt = 1;
5479           break;
5480         }
5481       cp1++;
5482       cp1 = strchr(cp1, '/');
5483     }
5484   }
5485
5486   /* Look for "." and ".." */
5487   if (decc_filename_unix_report) {
5488     if (spec[0] == '.') {
5489       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5490         cmp_rslt = 1;
5491       }
5492       else {
5493         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5494           cmp_rslt = 1;
5495         }
5496       }
5497     }
5498   }
5499   /* This is already UNIX or at least nothing VMS understands */
5500   if (cmp_rslt) {
5501     strcpy(rslt,spec);
5502     return rslt;
5503   }
5504
5505   cp1 = rslt;
5506   cp2 = spec;
5507   dirend = strrchr(spec,']');
5508   if (dirend == NULL) dirend = strrchr(spec,'>');
5509   if (dirend == NULL) dirend = strchr(spec,':');
5510   if (dirend == NULL) {
5511     strcpy(rslt,spec);
5512     return rslt;
5513   }
5514
5515   /* Special case 1 - sys$posix_root = / */
5516 #if __CRTL_VER >= 70000000
5517   if (!decc_disable_posix_root) {
5518     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5519       *cp1 = '/';
5520       cp1++;
5521       cp2 = cp2 + 15;
5522       }
5523   }
5524 #endif
5525
5526   /* Special case 2 - Convert NLA0: to /dev/null */
5527 #if __CRTL_VER < 70000000
5528   cmp_rslt = strncmp(spec,"NLA0:", 5);
5529   if (cmp_rslt != 0)
5530      cmp_rslt = strncmp(spec,"nla0:", 5);
5531 #else
5532   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5533 #endif
5534   if (cmp_rslt == 0) {
5535     strcpy(rslt, "/dev/null");
5536     cp1 = cp1 + 9;
5537     cp2 = cp2 + 5;
5538     if (spec[6] != '\0') {
5539       cp1[9] == '/';
5540       cp1++;
5541       cp2++;
5542     }
5543   }
5544
5545    /* Also handle special case "SYS$SCRATCH:" */
5546 #if __CRTL_VER < 70000000
5547   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5548   if (cmp_rslt != 0)
5549      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5550 #else
5551   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5552 #endif
5553   tmp = PerlMem_malloc(VMS_MAXRSS);
5554   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5555   if (cmp_rslt == 0) {
5556   int islnm;
5557
5558     islnm = my_trnlnm(tmp, "TMP", 0);
5559     if (!islnm) {
5560       strcpy(rslt, "/tmp");
5561       cp1 = cp1 + 4;
5562       cp2 = cp2 + 12;
5563       if (spec[12] != '\0') {
5564         cp1[4] == '/';
5565         cp1++;
5566         cp2++;
5567       }
5568     }
5569   }
5570
5571   if (*cp2 != '[' && *cp2 != '<') {
5572     *(cp1++) = '/';
5573   }
5574   else {  /* the VMS spec begins with directories */
5575     cp2++;
5576     if (*cp2 == ']' || *cp2 == '>') {
5577       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5578       PerlMem_free(tmp);
5579       return rslt;
5580     }
5581     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5582       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5583         if (ts) Safefree(rslt);
5584         PerlMem_free(tmp);
5585         return NULL;
5586       }
5587       trnlnm_iter_count = 0;
5588       do {
5589         cp3 = tmp;
5590         while (*cp3 != ':' && *cp3) cp3++;
5591         *(cp3++) = '\0';
5592         if (strchr(cp3,']') != NULL) break;
5593         trnlnm_iter_count++;
5594         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5595       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5596       if (ts && !buf &&
5597           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5598         retlen = devlen + dirlen;
5599         Renew(rslt,retlen+1+2*expand,char);
5600         cp1 = rslt;
5601       }
5602       cp3 = tmp;
5603       *(cp1++) = '/';
5604       while (*cp3) {
5605         *(cp1++) = *(cp3++);
5606         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5607             PerlMem_free(tmp);
5608             return NULL; /* No room */
5609         }
5610       }
5611       *(cp1++) = '/';
5612     }
5613     if ((*cp2 == '^')) {
5614         /* EFS file escape, pass the next character as is */
5615         /* Fix me: HEX encoding for UNICODE not implemented */
5616         cp2++;
5617     }
5618     else if ( *cp2 == '.') {
5619       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5620         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5621         cp2 += 3;
5622       }
5623       else cp2++;
5624     }
5625   }
5626   PerlMem_free(tmp);
5627   for (; cp2 <= dirend; cp2++) {
5628     if ((*cp2 == '^')) {
5629         /* EFS file escape, pass the next character as is */
5630         /* Fix me: HEX encoding for UNICODE not implemented */
5631         cp2++;
5632         *(cp1++) = *cp2;
5633     }
5634     if (*cp2 == ':') {
5635       *(cp1++) = '/';
5636       if (*(cp2+1) == '[') cp2++;
5637     }
5638     else if (*cp2 == ']' || *cp2 == '>') {
5639       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5640     }
5641     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5642       *(cp1++) = '/';
5643       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5644         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5645                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5646         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5647             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5648       }
5649       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5650         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5651         cp2 += 2;
5652       }
5653     }
5654     else if (*cp2 == '-') {
5655       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5656         while (*cp2 == '-') {
5657           cp2++;
5658           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5659         }
5660         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5661           if (ts) Safefree(rslt);                        /* filespecs like */
5662           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5663           return NULL;
5664         }
5665       }
5666       else *(cp1++) = *cp2;
5667     }
5668     else *(cp1++) = *cp2;
5669   }
5670   while (*cp2) *(cp1++) = *(cp2++);
5671   *cp1 = '\0';
5672
5673   /* This still leaves /000000/ when working with a
5674    * VMS device root or concealed root.
5675    */
5676   {
5677   int ulen;
5678   char * zeros;
5679
5680       ulen = strlen(rslt);
5681
5682       /* Get rid of "000000/ in rooted filespecs */
5683       if (ulen > 7) {
5684         zeros = strstr(rslt, "/000000/");
5685         if (zeros != NULL) {
5686           int mlen;
5687           mlen = ulen - (zeros - rslt) - 7;
5688           memmove(zeros, &zeros[7], mlen);
5689           ulen = ulen - 7;
5690           rslt[ulen] = '\0';
5691         }
5692       }
5693   }
5694
5695   return rslt;
5696
5697 }  /* end of do_tounixspec() */
5698 /*}}}*/
5699 /* External entry points */
5700 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5701 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5702
5703 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5704
5705 static int posix_to_vmsspec
5706   (char *vmspath, int vmspath_len, const char *unixpath) {
5707 int sts;
5708 struct FAB myfab = cc$rms_fab;
5709 struct NAML mynam = cc$rms_naml;
5710 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5711  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5712 char *esa;
5713 char *vms_delim;
5714 int dir_flag;
5715 int unixlen;
5716
5717   /* If not a posix spec already, convert it */
5718   dir_flag = 0;
5719   unixlen = strlen(unixpath);
5720   if (unixlen == 0) {
5721     vmspath[0] = '\0';
5722     return SS$_NORMAL;
5723   }
5724   if (strncmp(unixpath,"\"^UP^",5) != 0) {
5725     sprintf(vmspath,"\"^UP^%s\"",unixpath);
5726   }
5727   else {
5728     /* This is already a VMS specification, no conversion */
5729     unixlen--;
5730     strncpy(vmspath,unixpath, vmspath_len);
5731   }
5732   vmspath[vmspath_len] = 0;
5733   if (unixpath[unixlen - 1] == '/')
5734   dir_flag = 1;
5735   esa = PerlMem_malloc(VMS_MAXRSS);
5736   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5737   myfab.fab$l_fna = vmspath;
5738   myfab.fab$b_fns = strlen(vmspath);
5739   myfab.fab$l_naml = &mynam;
5740   mynam.naml$l_esa = NULL;
5741   mynam.naml$b_ess = 0;
5742   mynam.naml$l_long_expand = esa;
5743   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5744   mynam.naml$l_rsa = NULL;
5745   mynam.naml$b_rss = 0;
5746   if (decc_efs_case_preserve)
5747     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5748   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5749
5750   /* Set up the remaining naml fields */
5751   sts = sys$parse(&myfab);
5752
5753   /* It failed! Try again as a UNIX filespec */
5754   if (!(sts & 1)) {
5755     PerlMem_free(esa);
5756     return sts;
5757   }
5758
5759    /* get the Device ID and the FID */
5760    sts = sys$search(&myfab);
5761    /* on any failure, returned the POSIX ^UP^ filespec */
5762    if (!(sts & 1)) {
5763       PerlMem_free(esa);
5764       return sts;
5765    }
5766    specdsc.dsc$a_pointer = vmspath;
5767    specdsc.dsc$w_length = vmspath_len;
5768
5769    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5770    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5771    sts = lib$fid_to_name
5772       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5773
5774   /* on any failure, returned the POSIX ^UP^ filespec */
5775   if (!(sts & 1)) {
5776      /* This can happen if user does not have permission to read directories */
5777      if (strncmp(unixpath,"\"^UP^",5) != 0)
5778        sprintf(vmspath,"\"^UP^%s\"",unixpath);
5779      else
5780        strcpy(vmspath, unixpath);
5781   }
5782   else {
5783     vmspath[specdsc.dsc$w_length] = 0;
5784
5785     /* Are we expecting a directory? */
5786     if (dir_flag != 0) {
5787     int i;
5788     char *eptr;
5789
5790       eptr = NULL;
5791
5792       i = specdsc.dsc$w_length - 1;
5793       while (i > 0) {
5794       int zercnt;
5795         zercnt = 0;
5796         /* Version must be '1' */
5797         if (vmspath[i--] != '1')
5798           break;
5799         /* Version delimiter is one of ".;" */
5800         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5801           break;
5802         i--;
5803         if (vmspath[i--] != 'R')
5804           break;
5805         if (vmspath[i--] != 'I')
5806           break;
5807         if (vmspath[i--] != 'D')
5808           break;
5809         if (vmspath[i--] != '.')
5810           break;
5811         eptr = &vmspath[i+1];
5812         while (i > 0) {
5813           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5814             if (vmspath[i-1] != '^') {
5815               if (zercnt != 6) {
5816                 *eptr = vmspath[i];
5817                 eptr[1] = '\0';
5818                 vmspath[i] = '.';
5819                 break;
5820               }
5821               else {
5822                 /* Get rid of 6 imaginary zero directory filename */
5823                 vmspath[i+1] = '\0';
5824               }
5825             }
5826           }
5827           if (vmspath[i] == '0')
5828             zercnt++;
5829           else
5830             zercnt = 10;
5831           i--;
5832         }
5833         break;
5834       }
5835     }
5836   }
5837   PerlMem_free(esa);
5838   return sts;
5839 }
5840
5841 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5842 static int posix_to_vmsspec_hardway
5843   (char *vmspath, int vmspath_len, const char *unixpath) {
5844
5845 char *esa;
5846 const char *unixptr;
5847 char *vmsptr;
5848 const char *lastslash;
5849 const char *lastdot;
5850 int unixlen;
5851 int vmslen;
5852 int dir_start;
5853 int dir_dot;
5854 int quoted;
5855
5856
5857   unixptr = unixpath;
5858   dir_dot = 0;
5859
5860   /* Ignore leading "/" characters */
5861   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5862     unixptr++;
5863   }
5864   unixlen = strlen(unixptr);
5865
5866   /* Do nothing with blank paths */
5867   if (unixlen == 0) {
5868     vmspath[0] = '\0';
5869     return SS$_NORMAL;
5870   }
5871
5872   lastslash = strrchr(unixptr,'/');
5873   lastdot = strrchr(unixptr,'.');
5874
5875
5876   /* last dot is last dot or past end of string */
5877   if (lastdot == NULL)
5878     lastdot = unixptr + unixlen;
5879
5880   /* if no directories, set last slash to beginning of string */
5881   if (lastslash == NULL) {
5882     lastslash = unixptr;
5883   }
5884   else {
5885     /* Watch out for trailing "." after last slash, still a directory */
5886     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5887       lastslash = unixptr + unixlen;
5888     }
5889
5890     /* Watch out for traiing ".." after last slash, still a directory */
5891     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5892       lastslash = unixptr + unixlen;
5893     }
5894
5895     /* dots in directories are aways escaped */
5896     if (lastdot < lastslash)
5897       lastdot = unixptr + unixlen;
5898   }
5899
5900   /* if (unixptr < lastslash) then we are in a directory */
5901
5902   dir_start = 0;
5903   quoted = 0;
5904
5905   vmsptr = vmspath;
5906   vmslen = 0;
5907
5908   /* This could have a "^UP^ on the front */
5909   if (strncmp(unixptr,"\"^UP^",5) == 0) {
5910     quoted = 1;
5911     unixptr+= 5;
5912   }
5913
5914   /* Start with the UNIX path */
5915   if (*unixptr != '/') {
5916     /* relative paths */
5917     if (lastslash > unixptr) {
5918     int dotdir_seen;
5919
5920       /* skip leading ./ */
5921       dotdir_seen = 0;
5922       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5923         dotdir_seen = 1;
5924         unixptr++;
5925         unixptr++;
5926       }
5927
5928       /* Are we still in a directory? */
5929       if (unixptr <= lastslash) {
5930         *vmsptr++ = '[';
5931         vmslen = 1;
5932         dir_start = 1;
5933
5934         /* if not backing up, then it is relative forward. */
5935         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5936               ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5937           *vmsptr++ = '.';
5938           vmslen++;
5939           dir_dot = 1;
5940         }
5941        }
5942        else {
5943          if (dotdir_seen) {
5944            /* Perl wants an empty directory here to tell the difference
5945             * between a DCL commmand and a filename
5946             */
5947           *vmsptr++ = '[';
5948           *vmsptr++ = ']';
5949           vmslen = 2;
5950         }
5951       }
5952     }
5953     else {
5954       /* Handle two special files . and .. */
5955       if (unixptr[0] == '.') {
5956         if (unixptr[1] == '\0') {
5957           *vmsptr++ = '[';
5958           *vmsptr++ = ']';
5959           vmslen += 2;
5960           *vmsptr++ = '\0';
5961           return SS$_NORMAL;
5962         }
5963         if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5964           *vmsptr++ = '[';
5965           *vmsptr++ = '-';
5966           *vmsptr++ = ']';
5967           vmslen += 3;
5968           *vmsptr++ = '\0';
5969           return SS$_NORMAL;
5970         }
5971       }
5972     }
5973   }
5974   else {        /* Absolute PATH handling */
5975   int sts;
5976   char * nextslash;
5977   int seg_len;
5978     /* Need to find out where root is */
5979
5980     /* In theory, this procedure should never get an absolute POSIX pathname
5981      * that can not be found on the POSIX root.
5982      * In practice, that can not be relied on, and things will show up
5983      * here that are a VMS device name or concealed logical name instead.
5984      * So to make things work, this procedure must be tolerant.
5985      */
5986     esa = PerlMem_malloc(vmspath_len);
5987     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5988
5989     sts = SS$_NORMAL;
5990     nextslash = strchr(&unixptr[1],'/');
5991     seg_len = 0;
5992     if (nextslash != NULL) {
5993       seg_len = nextslash - &unixptr[1];
5994       strncpy(vmspath, unixptr, seg_len + 1);
5995       vmspath[seg_len+1] = 0;
5996       sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5997     }
5998
5999     if (sts & 1) {
6000       /* This is verified to be a real path */
6001
6002       sts = posix_to_vmsspec(esa, vmspath_len, "/");
6003       strcpy(vmspath, esa);
6004       vmslen = strlen(vmspath);
6005       vmsptr = vmspath + vmslen;
6006       unixptr++;
6007       if (unixptr < lastslash) {
6008       char * rptr;
6009         vmsptr--;
6010         *vmsptr++ = '.';
6011         dir_start = 1;
6012         dir_dot = 1;
6013         if (vmslen > 7) {
6014         int cmp;
6015           rptr = vmsptr - 7;
6016           cmp = strcmp(rptr,"000000.");
6017           if (cmp == 0) {
6018             vmslen -= 7;
6019             vmsptr -= 7;
6020             vmsptr[1] = '\0';
6021           } /* removing 6 zeros */
6022         } /* vmslen < 7, no 6 zeros possible */
6023       } /* Not in a directory */
6024     } /* end of verified real path handling */
6025     else {
6026     int add_6zero;
6027     int islnm;
6028
6029       /* Ok, we have a device or a concealed root that is not in POSIX
6030        * or we have garbage.  Make the best of it.
6031        */
6032
6033       /* Posix to VMS destroyed this, so copy it again */
6034       strncpy(vmspath, &unixptr[1], seg_len);
6035       vmspath[seg_len] = 0;
6036       vmslen = seg_len;
6037       vmsptr = &vmsptr[vmslen];
6038       islnm = 0;
6039
6040       /* Now do we need to add the fake 6 zero directory to it? */
6041       add_6zero = 1;
6042       if ((*lastslash == '/') && (nextslash < lastslash)) {
6043         /* No there is another directory */
6044         add_6zero = 0;
6045       }
6046       else {
6047       int trnend;
6048
6049         /* now we have foo:bar or foo:[000000]bar to decide from */
6050         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6051         trnend = islnm ? islnm - 1 : 0;
6052
6053         /* if this was a logical name, ']' or '>' must be present */
6054         /* if not a logical name, then assume a device and hope. */
6055         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6056
6057         /* if log name and trailing '.' then rooted - treat as device */
6058         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6059
6060         /* Fix me, if not a logical name, a device lookup should be
6061          * done to see if the device is file structured.  If the device
6062          * is not file structured, the 6 zeros should not be put on.
6063          *
6064          * As it is, perl is occasionally looking for dev:[000000]tty.
6065          * which looks a little strange.
6066          */
6067
6068         if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
6069           /* No real directory present */
6070           add_6zero = 1;
6071         }
6072       }
6073
6074       /* Put the device delimiter on */
6075       *vmsptr++ = ':';
6076       vmslen++;
6077       unixptr = nextslash;
6078       unixptr++;
6079
6080       /* Start directory if needed */
6081       if (!islnm || add_6zero) {
6082         *vmsptr++ = '[';
6083         vmslen++;
6084         dir_start = 1;
6085       }
6086
6087       /* add fake 000000] if needed */
6088       if (add_6zero) {
6089         *vmsptr++ = '0';
6090         *vmsptr++ = '0';
6091         *vmsptr++ = '0';
6092         *vmsptr++ = '0';
6093         *vmsptr++ = '0';
6094         *vmsptr++ = '0';
6095         *vmsptr++ = ']';
6096         vmslen += 7;
6097         dir_start = 0;
6098       }
6099
6100     } /* non-POSIX translation */
6101     PerlMem_free(esa);
6102   } /* End of relative/absolute path handling */
6103
6104   while ((*unixptr) && (vmslen < vmspath_len)){
6105   int dash_flag;
6106
6107     dash_flag = 0;
6108
6109     if (dir_start != 0) {
6110
6111       /* First characters in a directory are handled special */
6112       while ((*unixptr == '/') ||
6113              ((*unixptr == '.') &&
6114               ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
6115       int loop_flag;
6116
6117         loop_flag = 0;
6118
6119         /* Skip redundant / in specification */
6120         while ((*unixptr == '/') && (dir_start != 0)) {
6121           loop_flag = 1;
6122           unixptr++;
6123           if (unixptr == lastslash)
6124             break;
6125         }
6126         if (unixptr == lastslash)
6127           break;
6128
6129         /* Skip redundant ./ characters */
6130         while ((*unixptr == '.') &&
6131                ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
6132           loop_flag = 1;
6133           unixptr++;
6134           if (unixptr == lastslash)
6135             break;
6136           if (*unixptr == '/')
6137             unixptr++;
6138         }
6139         if (unixptr == lastslash)
6140           break;
6141
6142         /* Skip redundant ../ characters */
6143         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6144              ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
6145           /* Set the backing up flag */
6146           loop_flag = 1;
6147           dir_dot = 0;
6148           dash_flag = 1;
6149           *vmsptr++ = '-';
6150           vmslen++;
6151           unixptr++; /* first . */
6152           unixptr++; /* second . */
6153           if (unixptr == lastslash)
6154             break;
6155           if (*unixptr == '/') /* The slash */
6156             unixptr++;
6157         }
6158         if (unixptr == lastslash)
6159           break;
6160
6161         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6162         /* Not needed when VMS is pretending to be UNIX. */
6163
6164         /* Is this loop stuck because of too many dots? */
6165         if (loop_flag == 0) {
6166           /* Exit the loop and pass the rest through */
6167           break;
6168         }
6169       }
6170
6171       /* Are we done with directories yet? */
6172       if (unixptr >= lastslash) {
6173
6174         /* Watch out for trailing dots */
6175         if (dir_dot != 0) {
6176             vmslen --;
6177             vmsptr--;
6178         }
6179         *vmsptr++ = ']';
6180         vmslen++;
6181         dash_flag = 0;
6182         dir_start = 0;
6183         if (*unixptr == '/')
6184           unixptr++;
6185       }
6186       else {
6187         /* Have we stopped backing up? */
6188         if (dash_flag) {
6189           *vmsptr++ = '.';
6190           vmslen++;
6191           dash_flag = 0;
6192           /* dir_start continues to be = 1 */
6193         }
6194         if (*unixptr == '-') {
6195           *vmsptr++ = '^';
6196           *vmsptr++ = *unixptr++;
6197           vmslen += 2;
6198           dir_start = 0;
6199
6200           /* Now are we done with directories yet? */
6201           if (unixptr >= lastslash) {
6202
6203             /* Watch out for trailing dots */
6204             if (dir_dot != 0) {
6205               vmslen --;
6206               vmsptr--;
6207             }
6208
6209             *vmsptr++ = ']';
6210             vmslen++;
6211             dash_flag = 0;
6212             dir_start = 0;
6213           }
6214         }
6215       }
6216     }
6217
6218     /* All done? */
6219     if (*unixptr == '\0')
6220       break;
6221
6222     /* Normal characters - More EFS work probably needed */
6223     dir_start = 0;
6224     dir_dot = 0;
6225
6226     switch(*unixptr) {
6227     case '/':
6228         /* remove multiple / */
6229         while (unixptr[1] == '/') {
6230            unixptr++;
6231         }
6232         if (unixptr == lastslash) {
6233           /* Watch out for trailing dots */
6234           if (dir_dot != 0) {
6235             vmslen --;
6236             vmsptr--;
6237           }
6238           *vmsptr++ = ']';
6239         }
6240         else {
6241           dir_start = 1;
6242           *vmsptr++ = '.';
6243           dir_dot = 1;
6244
6245           /* To do: Perl expects /.../ to be translated to [...] on VMS */
6246           /* Not needed when VMS is pretending to be UNIX. */
6247
6248         }
6249         dash_flag = 0;
6250         if (*unixptr != '\0')
6251           unixptr++;
6252         vmslen++;
6253         break;
6254     case '?':
6255         *vmsptr++ = '%';
6256         vmslen++;
6257         unixptr++;
6258         break;
6259     case ' ':
6260         *vmsptr++ = '^';
6261         *vmsptr++ = '_';
6262         vmslen += 2;
6263         unixptr++;
6264         break;
6265     case '.':
6266         if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
6267           *vmsptr++ = '^';
6268           *vmsptr++ = '.';
6269           vmslen += 2;
6270           unixptr++;
6271
6272           /* trailing dot ==> '^..' on VMS */
6273           if (*unixptr == '\0') {
6274             *vmsptr++ = '.';
6275             vmslen++;
6276           }
6277           *vmsptr++ = *unixptr++;
6278           vmslen ++;
6279         }
6280         if (quoted && (unixptr[1] == '\0')) {
6281           unixptr++;
6282           break;
6283         }
6284         *vmsptr++ = '^';
6285         *vmsptr++ = *unixptr++;
6286         vmslen += 2;
6287         break;
6288     case '~':
6289     case ';':
6290     case '\\':
6291         *vmsptr++ = '^';
6292         *vmsptr++ = *unixptr++;
6293         vmslen += 2;
6294         break;
6295     default:
6296         if (*unixptr != '\0') {
6297           *vmsptr++ = *unixptr++;
6298           vmslen++;
6299         }
6300         break;
6301     }
6302   }
6303
6304   /* Make sure directory is closed */
6305   if (unixptr == lastslash) {
6306     char *vmsptr2;
6307     vmsptr2 = vmsptr - 1;
6308
6309     if (*vmsptr2 != ']') {
6310       *vmsptr2--;
6311
6312       /* directories do not end in a dot bracket */
6313       if (*vmsptr2 == '.') {
6314         vmsptr2--;
6315
6316         /* ^. is allowed */
6317         if (*vmsptr2 != '^') {
6318           vmsptr--; /* back up over the dot */
6319         }
6320       }
6321       *vmsptr++ = ']';
6322     }
6323   }
6324   else {
6325     char *vmsptr2;
6326     /* Add a trailing dot if a file with no extension */
6327     vmsptr2 = vmsptr - 1;
6328     if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6329         (*lastdot != '.')) {
6330         *vmsptr++ = '.';
6331         vmslen++;
6332     }
6333   }
6334
6335   *vmsptr = '\0';
6336   return SS$_NORMAL;
6337 }
6338 #endif
6339
6340 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6341 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6342   static char __tovmsspec_retbuf[VMS_MAXRSS];
6343   char *rslt, *dirend;
6344   char *lastdot;
6345   char *vms_delim;
6346   register char *cp1;
6347   const char *cp2;
6348   unsigned long int infront = 0, hasdir = 1;
6349   int rslt_len;
6350   int no_type_seen;
6351
6352   if (path == NULL) return NULL;
6353   rslt_len = VMS_MAXRSS-1;
6354   if (buf) rslt = buf;
6355   else if (ts) Newx(rslt, VMS_MAXRSS, char);
6356   else rslt = __tovmsspec_retbuf;
6357   if (strpbrk(path,"]:>") ||
6358       (dirend = strrchr(path,'/')) == NULL) {
6359     if (path[0] == '.') {
6360       if (path[1] == '\0') strcpy(rslt,"[]");
6361       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6362       else strcpy(rslt,path); /* probably garbage */
6363     }
6364     else strcpy(rslt,path);
6365     return rslt;
6366   }
6367
6368    /* Posix specifications are now a native VMS format */
6369   /*--------------------------------------------------*/
6370 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6371   if (decc_posix_compliant_pathnames) {
6372     if (strncmp(path,"\"^UP^",5) == 0) {
6373       posix_to_vmsspec_hardway(rslt, rslt_len, path);
6374       return rslt;
6375     }
6376   }
6377 #endif
6378
6379   vms_delim = strpbrk(path,"]:>");
6380
6381   if ((vms_delim != NULL) ||
6382       ((dirend = strrchr(path,'/')) == NULL)) {
6383
6384     /* VMS special characters found! */
6385
6386     if (path[0] == '.') {
6387       if (path[1] == '\0') strcpy(rslt,"[]");
6388       else if (path[1] == '.' && path[2] == '\0')
6389         strcpy(rslt,"[-]");
6390
6391       /* Dot preceeding a device or directory ? */
6392       else {
6393         /* If not in POSIX mode, pass it through and hope it works */
6394 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6395         if (!decc_posix_compliant_pathnames)
6396           strcpy(rslt,path); /* probably garbage */
6397         else
6398           posix_to_vmsspec_hardway(rslt, rslt_len, path);
6399 #else
6400         strcpy(rslt,path); /* probably garbage */
6401 #endif
6402       }
6403     }
6404     else {
6405
6406        /* If no VMS characters and in POSIX mode, convert it!
6407         * This is the easiest way to get directory specifications
6408         * handled correctly in POSIX mode
6409         */
6410 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6411       if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6412         posix_to_vmsspec_hardway(rslt, rslt_len, path);
6413       else {
6414         /* No unix path separators - presume VMS already */
6415         strcpy(rslt,path);
6416       }
6417 #else
6418       strcpy(rslt,path); /* probably garbage */
6419 #endif
6420     }
6421     return rslt;
6422   }
6423
6424 /* If POSIX mode active, handle the conversion */
6425 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6426   if (decc_posix_compliant_pathnames) {
6427     posix_to_vmsspec_hardway(rslt, rslt_len, path);
6428     return rslt;
6429   }
6430 #endif
6431
6432   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
6433     if (!*(dirend+2)) dirend +=2;
6434     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6435     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6436   }
6437
6438   cp1 = rslt;
6439   cp2 = path;
6440   lastdot = strrchr(cp2,'.');
6441   if (*cp2 == '/') {
6442     char *trndev;
6443     int islnm, rooted;
6444     STRLEN trnend;
6445
6446     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6447     if (!*(cp2+1)) {
6448       if (decc_disable_posix_root) {
6449         strcpy(rslt,"sys$disk:[000000]");
6450       }
6451       else {
6452         strcpy(rslt,"sys$posix_root:[000000]");
6453       }
6454       return rslt;
6455     }
6456     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6457     *cp1 = '\0';
6458     trndev = PerlMem_malloc(VMS_MAXRSS);
6459     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
6460     islnm =  my_trnlnm(rslt,trndev,0);
6461
6462      /* DECC special handling */
6463     if (!islnm) {
6464       if (strcmp(rslt,"bin") == 0) {
6465         strcpy(rslt,"sys$system");
6466         cp1 = rslt + 10;
6467         *cp1 = 0;
6468         islnm =  my_trnlnm(rslt,trndev,0);
6469       }
6470       else if (strcmp(rslt,"tmp") == 0) {
6471         strcpy(rslt,"sys$scratch");
6472         cp1 = rslt + 11;
6473         *cp1 = 0;
6474         islnm =  my_trnlnm(rslt,trndev,0);
6475       }
6476       else if (!decc_disable_posix_root) {
6477         strcpy(rslt, "sys$posix_root");
6478         cp1 = rslt + 13;
6479         *cp1 = 0;
6480         cp2 = path;
6481         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6482         islnm =  my_trnlnm(rslt,trndev,0);
6483       }
6484       else if (strcmp(rslt,"dev") == 0) {
6485         if (strncmp(cp2,"/null", 5) == 0) {
6486           if ((cp2[5] == 0) || (cp2[5] == '/')) {
6487             strcpy(rslt,"NLA0");
6488             cp1 = rslt + 4;
6489             *cp1 = 0;
6490             cp2 = cp2 + 5;
6491             islnm =  my_trnlnm(rslt,trndev,0);
6492           }
6493         }
6494       }
6495     }
6496
6497     trnend = islnm ? strlen(trndev) - 1 : 0;
6498     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6499     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6500     /* If the first element of the path is a logical name, determine
6501      * whether it has to be translated so we can add more directories. */
6502     if (!islnm || rooted) {
6503       *(cp1++) = ':';
6504       *(cp1++) = '[';
6505       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6506       else cp2++;
6507     }
6508     else {
6509       if (cp2 != dirend) {
6510         strcpy(rslt,trndev);
6511         cp1 = rslt + trnend;
6512         if (*cp2 != 0) {
6513           *(cp1++) = '.';
6514           cp2++;
6515         }
6516       }
6517       else {
6518         if (decc_disable_posix_root) {
6519           *(cp1++) = ':';
6520           hasdir = 0;
6521         }
6522       }
6523     }
6524     PerlMem_free(trndev);
6525   }
6526   else {
6527     *(cp1++) = '[';
6528     if (*cp2 == '.') {
6529       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6530         cp2 += 2;         /* skip over "./" - it's redundant */
6531         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
6532       }
6533       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6534         *(cp1++) = '-';                                 /* "../" --> "-" */
6535         cp2 += 3;
6536       }
6537       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6538                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6539         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6540         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6541         cp2 += 4;
6542       }
6543       else if ((cp2 != lastdot) || (lastdot < dirend)) {
6544         /* Escape the extra dots in EFS file specifications */
6545         *(cp1++) = '^';
6546       }
6547       if (cp2 > dirend) cp2 = dirend;
6548     }
6549     else *(cp1++) = '.';
6550   }
6551   for (; cp2 < dirend; cp2++) {
6552     if (*cp2 == '/') {
6553       if (*(cp2-1) == '/') continue;
6554       if (*(cp1-1) != '.') *(cp1++) = '.';
6555       infront = 0;
6556     }
6557     else if (!infront && *cp2 == '.') {
6558       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6559       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
6560       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6561         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6562         else if (*(cp1-2) == '[') *(cp1-1) = '-';
6563         else {  /* back up over previous directory name */
6564           cp1--;
6565           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6566           if (*(cp1-1) == '[') {
6567             memcpy(cp1,"000000.",7);
6568             cp1 += 7;
6569           }
6570         }
6571         cp2 += 2;
6572         if (cp2 == dirend) break;
6573       }
6574       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6575                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6576         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6577         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6578         if (!*(cp2+3)) {
6579           *(cp1++) = '.';  /* Simulate trailing '/' */
6580           cp2 += 2;  /* for loop will incr this to == dirend */
6581         }
6582         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
6583       }
6584       else {
6585         if (decc_efs_charset == 0)
6586           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
6587         else {
6588           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
6589           *(cp1++) = '.';
6590         }
6591       }
6592     }
6593     else {
6594       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
6595       if (*cp2 == '.') {
6596         if (decc_efs_charset == 0)
6597           *(cp1++) = '_';
6598         else {
6599           *(cp1++) = '^';
6600           *(cp1++) = '.';
6601         }
6602       }
6603       else                  *(cp1++) =  *cp2;
6604       infront = 1;
6605     }
6606   }
6607   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6608   if (hasdir) *(cp1++) = ']';
6609   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
6610   /* fixme for ODS5 */
6611   no_type_seen = 0;
6612   if (cp2 > lastdot)
6613     no_type_seen = 1;
6614   while (*cp2) {
6615     switch(*cp2) {
6616     case '?':
6617         *(cp1++) = '%';
6618         cp2++;
6619     case ' ':
6620         *(cp1)++ = '^';
6621         *(cp1)++ = '_';
6622         cp2++;
6623         break;
6624     case '.':
6625         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6626             decc_readdir_dropdotnotype) {
6627           *(cp1)++ = '^';
6628           *(cp1)++ = '.';
6629           cp2++;
6630
6631           /* trailing dot ==> '^..' on VMS */
6632           if (*cp2 == '\0') {
6633             *(cp1++) = '.';
6634             no_type_seen = 0;
6635           }
6636         }
6637         else {
6638           *(cp1++) = *(cp2++);
6639           no_type_seen = 0;
6640         }
6641         break;
6642     case '\"':
6643     case '~':
6644     case '`':
6645     case '!':
6646     case '#':
6647     case '%':
6648     case '^':
6649     case '&':
6650     case '(':
6651     case ')':
6652     case '=':
6653     case '+':
6654     case '\'':
6655     case '@':
6656     case '[':
6657     case ']':
6658     case '{':
6659     case '}':
6660     case ':':
6661     case '\\':
6662     case '|':
6663     case '<':
6664     case '>':
6665         *(cp1++) = '^';
6666         *(cp1++) = *(cp2++);
6667         break;
6668     case ';':
6669         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6670          * which is wrong.  UNIX notation should be ".dir." unless
6671          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6672          * changing this behavior could break more things at this time.
6673          * efs character set effectively does not allow "." to be a version
6674          * delimiter as a further complication about changing this.
6675          */
6676         if (decc_filename_unix_report != 0) {
6677           *(cp1++) = '^';
6678         }
6679         *(cp1++) = *(cp2++);
6680         break;
6681     default:
6682         *(cp1++) = *(cp2++);
6683     }
6684   }
6685   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6686   char *lcp1;
6687     lcp1 = cp1;
6688     lcp1--;
6689      /* Fix me for "^]", but that requires making sure that you do
6690       * not back up past the start of the filename
6691       */
6692     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6693       *cp1++ = '.';
6694   }
6695   *cp1 = '\0';
6696
6697   return rslt;
6698
6699 }  /* end of do_tovmsspec() */
6700 /*}}}*/
6701 /* External entry points */
6702 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6703 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6704
6705 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6706 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6707   static char __tovmspath_retbuf[VMS_MAXRSS];
6708   int vmslen;
6709   char *pathified, *vmsified, *cp;
6710
6711   if (path == NULL) return NULL;
6712   pathified = PerlMem_malloc(VMS_MAXRSS);
6713   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
6714   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6715     PerlMem_free(pathified);
6716     return NULL;
6717   }
6718
6719   vmsified = NULL;
6720   if (buf == NULL)
6721      Newx(vmsified, VMS_MAXRSS, char);
6722   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0) == NULL) {
6723     PerlMem_free(pathified);
6724     if (vmsified) Safefree(vmsified);
6725     return NULL;
6726   }
6727   PerlMem_free(pathified);
6728   if (buf) {
6729     return buf;
6730   }
6731   else if (ts) {
6732     vmslen = strlen(vmsified);
6733     Newx(cp,vmslen+1,char);
6734     memcpy(cp,vmsified,vmslen);
6735     cp[vmslen] = '\0';
6736     Safefree(vmsified);
6737     return cp;
6738   }
6739   else {
6740     strcpy(__tovmspath_retbuf,vmsified);
6741     Safefree(vmsified);
6742     return __tovmspath_retbuf;
6743   }
6744
6745 }  /* end of do_tovmspath() */
6746 /*}}}*/
6747 /* External entry points */
6748 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6749 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6750
6751
6752 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6753 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6754   static char __tounixpath_retbuf[VMS_MAXRSS];
6755   int unixlen;
6756   char *pathified, *unixified, *cp;
6757
6758   if (path == NULL) return NULL;
6759   pathified = PerlMem_malloc(VMS_MAXRSS);
6760   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
6761   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6762     PerlMem_free(pathified);
6763     return NULL;
6764   }
6765
6766   unixified = NULL;
6767   if (buf == NULL) {
6768       Newx(unixified, VMS_MAXRSS, char);
6769   }
6770   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6771     PerlMem_free(pathified);
6772     if (unixified) Safefree(unixified);
6773     return NULL;
6774   }
6775   PerlMem_free(pathified);
6776   if (buf) {
6777     return buf;
6778   }
6779   else if (ts) {
6780     unixlen = strlen(unixified);
6781     Newx(cp,unixlen+1,char);
6782     memcpy(cp,unixified,unixlen);
6783     cp[unixlen] = '\0';
6784     Safefree(unixified);
6785     return cp;
6786   }
6787   else {
6788     strcpy(__tounixpath_retbuf,unixified);
6789     Safefree(unixified);
6790     return __tounixpath_retbuf;
6791   }
6792
6793 }  /* end of do_tounixpath() */
6794 /*}}}*/
6795 /* External entry points */
6796 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6797 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6798
6799 /*
6800  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
6801  *
6802  *****************************************************************************
6803  *                                                                           *
6804  *  Copyright (C) 1989-1994 by                                               *
6805  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
6806  *                                                                           *
6807  *  Permission is hereby  granted for the reproduction of this software,     *
6808  *  on condition that this copyright notice is included in the reproduction, *
6809  *  and that such reproduction is not for purposes of profit or material     *
6810  *  gain.                                                                    *
6811  *                                                                           *
6812  *  27-Aug-1994 Modified for inclusion in perl5                              *
6813  *              by Charles Bailey  bailey@newman.upenn.edu                   *
6814  *****************************************************************************
6815  */
6816
6817 /*
6818  * getredirection() is intended to aid in porting C programs
6819  * to VMS (Vax-11 C).  The native VMS environment does not support
6820  * '>' and '<' I/O redirection, or command line wild card expansion,
6821  * or a command line pipe mechanism using the '|' AND background
6822  * command execution '&'.  All of these capabilities are provided to any
6823  * C program which calls this procedure as the first thing in the
6824  * main program.
6825  * The piping mechanism will probably work with almost any 'filter' type
6826  * of program.  With suitable modification, it may useful for other
6827  * portability problems as well.
6828  *
6829  * Author:  Mark Pizzolato      mark@infocomm.com
6830  */
6831 struct list_item
6832     {
6833     struct list_item *next;
6834     char *value;
6835     };
6836
6837 static void add_item(struct list_item **head,
6838                      struct list_item **tail,
6839                      char *value,
6840                      int *count);
6841
6842 static void mp_expand_wild_cards(pTHX_ char *item,
6843                                 struct list_item **head,
6844                                 struct list_item **tail,
6845                                 int *count);
6846
6847 static int background_process(pTHX_ int argc, char **argv);
6848
6849 static void pipe_and_fork(pTHX_ char **cmargv);
6850
6851 /*{{{ void getredirection(int *ac, char ***av)*/
6852 static void
6853 mp_getredirection(pTHX_ int *ac, char ***av)
6854 /*
6855  * Process vms redirection arg's.  Exit if any error is seen.
6856  * If getredirection() processes an argument, it is erased
6857  * from the vector.  getredirection() returns a new argc and argv value.
6858  * In the event that a background command is requested (by a trailing "&"),
6859  * this routine creates a background subprocess, and simply exits the program.
6860  *
6861  * Warning: do not try to simplify the code for vms.  The code
6862  * presupposes that getredirection() is called before any data is
6863  * read from stdin or written to stdout.
6864  *
6865  * Normal usage is as follows:
6866  *
6867  *      main(argc, argv)
6868  *      int             argc;
6869  *      char            *argv[];
6870  *      {
6871  *              getredirection(&argc, &argv);
6872  *      }
6873  */
6874 {
6875     int                 argc = *ac;     /* Argument Count         */
6876     char                **argv = *av;   /* Argument Vector        */
6877     char                *ap;            /* Argument pointer       */
6878     int                 j;              /* argv[] index           */
6879     int                 item_count = 0; /* Count of Items in List */
6880     struct list_item    *list_head = 0; /* First Item in List       */
6881     struct list_item    *list_tail;     /* Last Item in List        */
6882     char                *in = NULL;     /* Input File Name          */
6883     char                *out = NULL;    /* Output File Name         */
6884     char                *outmode = "w"; /* Mode to Open Output File */
6885     char                *err = NULL;    /* Error File Name          */
6886     char                *errmode = "w"; /* Mode to Open Error File  */
6887     int                 cmargc = 0;     /* Piped Command Arg Count  */
6888     char                **cmargv = NULL;/* Piped Command Arg Vector */
6889
6890     /*
6891      * First handle the case where the last thing on the line ends with
6892      * a '&'.  This indicates the desire for the command to be run in a
6893      * subprocess, so we satisfy that desire.
6894      */
6895     ap = argv[argc-1];
6896     if (0 == strcmp("&", ap))
6897        exit(background_process(aTHX_ --argc, argv));
6898     if (*ap && '&' == ap[strlen(ap)-1])
6899         {
6900         ap[strlen(ap)-1] = '\0';
6901        exit(background_process(aTHX_ argc, argv));
6902         }
6903     /*
6904      * Now we handle the general redirection cases that involve '>', '>>',
6905      * '<', and pipes '|'.
6906      */
6907     for (j = 0; j < argc; ++j)
6908         {
6909         if (0 == strcmp("<", argv[j]))
6910             {
6911             if (j+1 >= argc)
6912                 {
6913                 fprintf(stderr,"No input file after < on command line");
6914                 exit(LIB$_WRONUMARG);
6915                 }
6916             in = argv[++j];
6917             continue;
6918             }
6919         if ('<' == *(ap = argv[j]))
6920             {
6921             in = 1 + ap;
6922             continue;
6923             }
6924         if (0 == strcmp(">", ap))
6925             {
6926             if (j+1 >= argc)
6927                 {
6928                 fprintf(stderr,"No output file after > on command line");
6929                 exit(LIB$_WRONUMARG);
6930                 }
6931             out = argv[++j];
6932             continue;
6933             }
6934         if ('>' == *ap)
6935             {
6936             if ('>' == ap[1])
6937                 {
6938                 outmode = "a";
6939                 if ('\0' == ap[2])
6940                     out = argv[++j];
6941                 else
6942                     out = 2 + ap;
6943                 }
6944             else
6945                 out = 1 + ap;
6946             if (j >= argc)
6947                 {
6948                 fprintf(stderr,"No output file after > or >> on command line");
6949                 exit(LIB$_WRONUMARG);
6950                 }
6951             continue;
6952             }
6953         if (('2' == *ap) && ('>' == ap[1]))
6954             {
6955             if ('>' == ap[2])
6956                 {
6957                 errmode = "a";
6958                 if ('\0' == ap[3])
6959                     err = argv[++j];
6960                 else
6961                     err = 3 + ap;
6962                 }
6963             else
6964                 if ('\0' == ap[2])
6965                     err = argv[++j];
6966                 else
6967                     err = 2 + ap;
6968             if (j >= argc)
6969                 {
6970                 fprintf(stderr,"No output file after 2> or 2>> on command line");
6971                 exit(LIB$_WRONUMARG);
6972                 }
6973             continue;
6974             }
6975         if (0 == strcmp("|", argv[j]))
6976             {
6977             if (j+1 >= argc)
6978                 {
6979                 fprintf(stderr,"No command into which to pipe on command line");
6980                 exit(LIB$_WRONUMARG);
6981                 }
6982             cmargc = argc-(j+1);
6983             cmargv = &argv[j+1];
6984             argc = j;
6985             continue;
6986             }
6987         if ('|' == *(ap = argv[j]))
6988             {
6989             ++argv[j];
6990             cmargc = argc-j;
6991             cmargv = &argv[j];
6992             argc = j;
6993             continue;
6994             }
6995         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6996         }
6997     /*
6998      * Allocate and fill in the new argument vector, Some Unix's terminate
6999      * the list with an extra null pointer.
7000      */
7001     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7002     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7003     *av = argv;
7004     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7005         argv[j] = list_head->value;
7006     *ac = item_count;
7007     if (cmargv != NULL)
7008         {
7009         if (out != NULL)
7010             {
7011             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7012             exit(LIB$_INVARGORD);
7013             }
7014         pipe_and_fork(aTHX_ cmargv);
7015         }
7016
7017     /* Check for input from a pipe (mailbox) */
7018
7019     if (in == NULL && 1 == isapipe(0))
7020         {
7021         char mbxname[L_tmpnam];
7022         long int bufsize;
7023         long int dvi_item = DVI$_DEVBUFSIZ;
7024         $DESCRIPTOR(mbxnam, "");
7025         $DESCRIPTOR(mbxdevnam, "");
7026
7027         /* Input from a pipe, reopen it in binary mode to disable       */
7028         /* carriage control processing.                                 */
7029
7030         fgetname(stdin, mbxname);
7031         mbxnam.dsc$a_pointer = mbxname;
7032         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7033         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7034         mbxdevnam.dsc$a_pointer = mbxname;
7035         mbxdevnam.dsc$w_length = sizeof(mbxname);
7036         dvi_item = DVI$_DEVNAM;
7037         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7038         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7039         set_errno(0);
7040         set_vaxc_errno(1);
7041         freopen(mbxname, "rb", stdin);
7042         if (errno != 0)
7043             {
7044             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7045             exit(vaxc$errno);
7046             }
7047         }
7048     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7049         {
7050         fprintf(stderr,"Can't open input file %s as stdin",in);
7051         exit(vaxc$errno);
7052         }
7053     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7054         {
7055         fprintf(stderr,"Can't open output file %s as stdout",out);
7056         exit(vaxc$errno);
7057         }
7058         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7059
7060     if (err != NULL) {
7061         if (strcmp(err,"&1") == 0) {
7062             dup2(fileno(stdout), fileno(stderr));
7063             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7064         } else {
7065         FILE *tmperr;
7066         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7067             {
7068             fprintf(stderr,"Can't open error file %s as stderr",err);
7069             exit(vaxc$errno);
7070             }
7071             fclose(tmperr);
7072            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7073                 {
7074                 exit(vaxc$errno);
7075                 }
7076             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7077         }
7078         }
7079 #ifdef ARGPROC_DEBUG
7080     PerlIO_printf(Perl_debug_log, "Arglist:\n");
7081     for (j = 0; j < *ac;  ++j)
7082         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7083 #endif
7084    /* Clear errors we may have hit expanding wildcards, so they don't
7085       show up in Perl's $! later */
7086    set_errno(0); set_vaxc_errno(1);
7087 }  /* end of getredirection() */
7088 /*}}}*/
7089
7090 static void add_item(struct list_item **head,
7091                      struct list_item **tail,
7092                      char *value,
7093                      int *count)
7094 {
7095     if (*head == 0)
7096         {
7097         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7098         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7099         *tail = *head;
7100         }
7101     else {
7102         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7103         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7104         *tail = (*tail)->next;
7105         }
7106     (*tail)->value = value;
7107     ++(*count);
7108 }
7109
7110 static void mp_expand_wild_cards(pTHX_ char *item,
7111                               struct list_item **head,
7112                               struct list_item **tail,
7113                               int *count)
7114 {
7115 int expcount = 0;
7116 unsigned long int context = 0;
7117 int isunix = 0;
7118 int item_len = 0;
7119 char *had_version;
7120 char *had_device;
7121 int had_directory;
7122 char *devdir,*cp;
7123 char *vmsspec;
7124 $DESCRIPTOR(filespec, "");
7125 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7126 $DESCRIPTOR(resultspec, "");
7127 unsigned long int lff_flags = 0;
7128 int sts;
7129 int rms_sts;
7130
7131 #ifdef VMS_LONGNAME_SUPPORT
7132     lff_flags = LIB$M_FIL_LONG_NAMES;
7133 #endif
7134
7135     for (cp = item; *cp; cp++) {
7136         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7137         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7138     }
7139     if (!*cp || isspace(*cp))
7140         {
7141         add_item(head, tail, item, count);
7142         return;
7143         }
7144     else
7145         {
7146      /* "double quoted" wild card expressions pass as is */
7147      /* From DCL that means using e.g.:                  */
7148      /* perl program """perl.*"""                        */
7149      item_len = strlen(item);
7150      if ( '"' == *item && '"' == item[item_len-1] )
7151        {
7152        item++;
7153        item[item_len-2] = '\0';
7154        add_item(head, tail, item, count);
7155        return;
7156        }
7157      }
7158     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7159     resultspec.dsc$b_class = DSC$K_CLASS_D;
7160     resultspec.dsc$a_pointer = NULL;
7161     vmsspec = PerlMem_malloc(VMS_MAXRSS);
7162     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7163     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7164       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
7165     if (!isunix || !filespec.dsc$a_pointer)
7166       filespec.dsc$a_pointer = item;
7167     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7168     /*
7169      * Only return version specs, if the caller specified a version
7170      */
7171     had_version = strchr(item, ';');
7172     /*
7173      * Only return device and directory specs, if the caller specifed either.
7174      */
7175     had_device = strchr(item, ':');
7176     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7177
7178     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7179                                  (&filespec, &resultspec, &context,
7180                                   &defaultspec, 0, &rms_sts, &lff_flags)))
7181         {
7182         char *string;
7183         char *c;
7184
7185         string = PerlMem_malloc(resultspec.dsc$w_length+1);
7186         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7187         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7188         string[resultspec.dsc$w_length] = '\0';
7189         if (NULL == had_version)
7190             *(strrchr(string, ';')) = '\0';
7191         if ((!had_directory) && (had_device == NULL))
7192             {
7193             if (NULL == (devdir = strrchr(string, ']')))
7194                 devdir = strrchr(string, '>');
7195             strcpy(string, devdir + 1);
7196             }
7197         /*
7198          * Be consistent with what the C RTL has already done to the rest of
7199          * the argv items and lowercase all of these names.
7200          */
7201         if (!decc_efs_case_preserve) {
7202             for (c = string; *c; ++c)
7203             if (isupper(*c))
7204                 *c = tolower(*c);
7205         }
7206         if (isunix) trim_unixpath(string,item,1);
7207         add_item(head, tail, string, count);
7208         ++expcount;
7209     }
7210     PerlMem_free(vmsspec);
7211     if (sts != RMS$_NMF)
7212         {
7213         set_vaxc_errno(sts);
7214         switch (sts)
7215             {
7216             case RMS$_FNF: case RMS$_DNF:
7217                 set_errno(ENOENT); break;
7218             case RMS$_DIR:
7219                 set_errno(ENOTDIR); break;
7220             case RMS$_DEV:
7221                 set_errno(ENODEV); break;
7222             case RMS$_FNM: case RMS$_SYN:
7223                 set_errno(EINVAL); break;
7224             case RMS$_PRV:
7225                 set_errno(EACCES); break;
7226             default:
7227                 _ckvmssts_noperl(sts);
7228             }
7229         }
7230     if (expcount == 0)
7231         add_item(head, tail, item, count);
7232     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7233     _ckvmssts_noperl(lib$find_file_end(&context));
7234 }
7235
7236 static int child_st[2];/* Event Flag set when child process completes   */
7237
7238 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
7239
7240 static unsigned long int exit_handler(int *status)
7241 {
7242 short iosb[4];
7243
7244     if (0 == child_st[0])
7245         {
7246 #ifdef ARGPROC_DEBUG
7247         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7248 #endif
7249         fflush(stdout);     /* Have to flush pipe for binary data to    */
7250                             /* terminate properly -- <tp@mccall.com>    */
7251         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7252         sys$dassgn(child_chan);
7253         fclose(stdout);
7254         sys$synch(0, child_st);
7255         }
7256     return(1);
7257 }
7258
7259 static void sig_child(int chan)
7260 {
7261 #ifdef ARGPROC_DEBUG
7262     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7263 #endif
7264     if (child_st[0] == 0)
7265         child_st[0] = 1;
7266 }
7267
7268 static struct exit_control_block exit_block =
7269     {
7270     0,
7271     exit_handler,
7272     1,
7273     &exit_block.exit_status,
7274     0
7275     };
7276
7277 static void
7278 pipe_and_fork(pTHX_ char **cmargv)
7279 {
7280     PerlIO *fp;
7281     struct dsc$descriptor_s *vmscmd;
7282     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7283     int sts, j, l, ismcr, quote, tquote = 0;
7284
7285     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
7286     vms_execfree(vmscmd);
7287
7288     j = l = 0;
7289     p = subcmd;
7290     q = cmargv[0];
7291     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
7292               && toupper(*(q+2)) == 'R' && !*(q+3);
7293
7294     while (q && l < MAX_DCL_LINE_LENGTH) {
7295         if (!*q) {
7296             if (j > 0 && quote) {
7297                 *p++ = '"';
7298                 l++;
7299             }
7300             q = cmargv[++j];
7301             if (q) {
7302                 if (ismcr && j > 1) quote = 1;
7303                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
7304                 *p++ = ' ';
7305                 l++;
7306                 if (quote || tquote) {
7307                     *p++ = '"';
7308                     l++;
7309                 }
7310             }
7311         } else {
7312             if ((quote||tquote) && *q == '"') {
7313                 *p++ = '"';
7314                 l++;
7315             }
7316             *p++ = *q++;
7317             l++;
7318         }
7319     }
7320     *p = '\0';
7321
7322     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7323     if (fp == Nullfp) {
7324         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7325     }
7326 }
7327
7328 static int background_process(pTHX_ int argc, char **argv)
7329 {
7330 char command[MAX_DCL_SYMBOL + 1] = "$";
7331 $DESCRIPTOR(value, "");
7332 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7333 static $DESCRIPTOR(null, "NLA0:");
7334 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7335 char pidstring[80];
7336 $DESCRIPTOR(pidstr, "");
7337 int pid;
7338 unsigned long int flags = 17, one = 1, retsts;
7339 int len;
7340
7341     strcat(command, argv[0]);
7342     len = strlen(command);
7343     while (--argc && (len < MAX_DCL_SYMBOL))
7344         {
7345         strcat(command, " \"");
7346         strcat(command, *(++argv));
7347         strcat(command, "\"");
7348         len = strlen(command);
7349         }
7350     value.dsc$a_pointer = command;
7351     value.dsc$w_length = strlen(value.dsc$a_pointer);
7352     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7353     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7354     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7355         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7356     }
7357     else {
7358         _ckvmssts_noperl(retsts);
7359     }
7360 #ifdef ARGPROC_DEBUG
7361     PerlIO_printf(Perl_debug_log, "%s\n", command);
7362 #endif
7363     sprintf(pidstring, "%08X", pid);
7364     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7365     pidstr.dsc$a_pointer = pidstring;
7366     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7367     lib$set_symbol(&pidsymbol, &pidstr);
7368     return(SS$_NORMAL);
7369 }
7370 /*}}}*/
7371 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7372
7373
7374 /* OS-specific initialization at image activation (not thread startup) */
7375 /* Older VAXC header files lack these constants */
7376 #ifndef JPI$_RIGHTS_SIZE
7377 #  define JPI$_RIGHTS_SIZE 817
7378 #endif
7379 #ifndef KGB$M_SUBSYSTEM
7380 #  define KGB$M_SUBSYSTEM 0x8
7381 #endif
7382
7383 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7384
7385 /*{{{void vms_image_init(int *, char ***)*/
7386 void
7387 vms_image_init(int *argcp, char ***argvp)
7388 {
7389   char eqv[LNM$C_NAMLENGTH+1] = "";
7390   unsigned int len, tabct = 8, tabidx = 0;
7391   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7392   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7393   unsigned short int dummy, rlen;
7394   struct dsc$descriptor_s **tabvec;
7395 #if defined(PERL_IMPLICIT_CONTEXT)
7396   pTHX = NULL;
7397 #endif
7398   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
7399                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
7400                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7401                                  {          0,                0,    0,      0} };
7402
7403 #ifdef KILL_BY_SIGPRC
7404     Perl_csighandler_init();
7405 #endif
7406
7407   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7408   _ckvmssts_noperl(iosb[0]);
7409   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7410     if (iprv[i]) {           /* Running image installed with privs? */
7411       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
7412       will_taint = TRUE;
7413       break;
7414     }
7415   }
7416   /* Rights identifiers might trigger tainting as well. */
7417   if (!will_taint && (rlen || rsz)) {
7418     while (rlen < rsz) {
7419       /* We didn't get all the identifiers on the first pass.  Allocate a
7420        * buffer much larger than $GETJPI wants (rsz is size in bytes that
7421        * were needed to hold all identifiers at time of last call; we'll
7422        * allocate that many unsigned long ints), and go back and get 'em.
7423        * If it gave us less than it wanted to despite ample buffer space,
7424        * something's broken.  Is your system missing a system identifier?
7425        */
7426       if (rsz <= jpilist[1].buflen) {
7427          /* Perl_croak accvios when used this early in startup. */
7428          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7429                          rsz, (unsigned long) jpilist[1].buflen,
7430                          "Check your rights database for corruption.\n");
7431          exit(SS$_ABORT);
7432       }
7433       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7434       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7435       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7436       jpilist[1].buflen = rsz * sizeof(unsigned long int);
7437       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7438       _ckvmssts_noperl(iosb[0]);
7439     }
7440     mask = jpilist[1].bufadr;
7441     /* Check attribute flags for each identifier (2nd longword); protected
7442      * subsystem identifiers trigger tainting.
7443      */
7444     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7445       if (mask[i] & KGB$M_SUBSYSTEM) {
7446         will_taint = TRUE;
7447         break;
7448       }
7449     }
7450     if (mask != rlst) PerlMem_free(mask);
7451   }
7452
7453   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7454    * logical, some versions of the CRTL will add a phanthom /000000/
7455    * directory.  This needs to be removed.
7456    */
7457   if (decc_filename_unix_report) {
7458   char * zeros;
7459   int ulen;
7460     ulen = strlen(argvp[0][0]);
7461     if (ulen > 7) {
7462       zeros = strstr(argvp[0][0], "/000000/");
7463       if (zeros != NULL) {
7464         int mlen;
7465         mlen = ulen - (zeros - argvp[0][0]) - 7;
7466         memmove(zeros, &zeros[7], mlen);
7467         ulen = ulen - 7;
7468         argvp[0][0][ulen] = '\0';
7469       }
7470     }
7471     /* It also may have a trailing dot that needs to be removed otherwise
7472      * it will be converted to VMS mode incorrectly.
7473      */
7474     ulen--;
7475     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7476       argvp[0][0][ulen] = '\0';
7477   }
7478
7479   /* We need to use this hack to tell Perl it should run with tainting,
7480    * since its tainting flag may be part of the PL_curinterp struct, which
7481    * hasn't been allocated when vms_image_init() is called.
7482    */
7483   if (will_taint) {
7484     char **newargv, **oldargv;
7485     oldargv = *argvp;
7486     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7487     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7488     newargv[0] = oldargv[0];
7489     newargv[1] = PerlMem_malloc(3 * sizeof(char));
7490     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7491     strcpy(newargv[1], "-T");
7492     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7493     (*argcp)++;
7494     newargv[*argcp] = NULL;
7495     /* We orphan the old argv, since we don't know where it's come from,
7496      * so we don't know how to free it.
7497      */
7498     *argvp = newargv;
7499   }
7500   else {  /* Did user explicitly request tainting? */
7501     int i;
7502     char *cp, **av = *argvp;
7503     for (i = 1; i < *argcp; i++) {
7504       if (*av[i] != '-') break;
7505       for (cp = av[i]+1; *cp; cp++) {
7506         if (*cp == 'T') { will_taint = 1; break; }
7507         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7508                   strchr("DFIiMmx",*cp)) break;
7509       }
7510       if (will_taint) break;
7511     }
7512   }
7513
7514   for (tabidx = 0;
7515        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7516        tabidx++) {
7517     if (!tabidx) {
7518       tabvec = (struct dsc$descriptor_s **)
7519             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7520       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7521     }
7522     else if (tabidx >= tabct) {
7523       tabct += 8;
7524       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7525       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7526     }
7527     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7528     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7529     tabvec[tabidx]->dsc$w_length  = 0;
7530     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
7531     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
7532     tabvec[tabidx]->dsc$a_pointer = NULL;
7533     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7534   }
7535   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7536
7537   getredirection(argcp,argvp);
7538 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7539   {
7540 # include <reentrancy.h>
7541   decc$set_reentrancy(C$C_MULTITHREAD);
7542   }
7543 #endif
7544   return;
7545 }
7546 /*}}}*/
7547
7548
7549 /* trim_unixpath()
7550  * Trim Unix-style prefix off filespec, so it looks like what a shell
7551  * glob expansion would return (i.e. from specified prefix on, not
7552  * full path).  Note that returned filespec is Unix-style, regardless
7553  * of whether input filespec was VMS-style or Unix-style.
7554  *
7555  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7556  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
7557  * vector of options; at present, only bit 0 is used, and if set tells
7558  * trim unixpath to try the current default directory as a prefix when
7559  * presented with a possibly ambiguous ... wildcard.
7560  *
7561  * Returns !=0 on success, with trimmed filespec replacing contents of
7562  * fspec, and 0 on failure, with contents of fpsec unchanged.
7563  */
7564 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7565 int
7566 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7567 {
7568   char *unixified, *unixwild,
7569        *template, *base, *end, *cp1, *cp2;
7570   register int tmplen, reslen = 0, dirs = 0;
7571
7572   unixwild = PerlMem_malloc(VMS_MAXRSS);
7573   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
7574   if (!wildspec || !fspec) return 0;
7575   template = unixwild;
7576   if (strpbrk(wildspec,"]>:") != NULL) {
7577     if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7578         PerlMem_free(unixwild);
7579         return 0;
7580     }
7581   }
7582   else {
7583     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7584     unixwild[VMS_MAXRSS-1] = 0;
7585   }
7586   unixified = PerlMem_malloc(VMS_MAXRSS);
7587   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
7588   if (strpbrk(fspec,"]>:") != NULL) {
7589     if (do_tounixspec(fspec,unixified,0) == NULL) {
7590         PerlMem_free(unixwild);
7591         PerlMem_free(unixified);
7592         return 0;
7593     }
7594     else base = unixified;
7595     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7596      * check to see that final result fits into (isn't longer than) fspec */
7597     reslen = strlen(fspec);
7598   }
7599   else base = fspec;
7600
7601   /* No prefix or absolute path on wildcard, so nothing to remove */
7602   if (!*template || *template == '/') {
7603     PerlMem_free(unixwild);
7604     if (base == fspec) {
7605         PerlMem_free(unixified);
7606         return 1;
7607     }
7608     tmplen = strlen(unixified);
7609     if (tmplen > reslen) {
7610         PerlMem_free(unixified);
7611         return 0;  /* not enough space */
7612     }
7613     /* Copy unixified resultant, including trailing NUL */
7614     memmove(fspec,unixified,tmplen+1);
7615     PerlMem_free(unixified);
7616     return 1;
7617   }
7618
7619   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
7620   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7621     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7622     for (cp1 = end ;cp1 >= base; cp1--)
7623       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7624         { cp1++; break; }
7625     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7626     PerlMem_free(unixified);
7627     PerlMem_free(unixwild);
7628     return 1;
7629   }
7630   else {
7631     char *tpl, *lcres;
7632     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7633     int ells = 1, totells, segdirs, match;
7634     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7635                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7636
7637     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7638     totells = ells;
7639     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7640     tpl = PerlMem_malloc(VMS_MAXRSS);
7641     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
7642     if (ellipsis == template && opts & 1) {
7643       /* Template begins with an ellipsis.  Since we can't tell how many
7644        * directory names at the front of the resultant to keep for an
7645        * arbitrary starting point, we arbitrarily choose the current
7646        * default directory as a starting point.  If it's there as a prefix,
7647        * clip it off.  If not, fall through and act as if the leading
7648        * ellipsis weren't there (i.e. return shortest possible path that
7649        * could match template).
7650        */
7651       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7652           PerlMem_free(tpl);
7653           PerlMem_free(unixified);
7654           PerlMem_free(unixwild);
7655           return 0;
7656       }
7657       if (!decc_efs_case_preserve) {
7658         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7659           if (_tolower(*cp1) != _tolower(*cp2)) break;
7660       }
7661       segdirs = dirs - totells;  /* Min # of dirs we must have left */
7662       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7663       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7664         memmove(fspec,cp2+1,end - cp2);
7665         PerlMem_free(tpl);
7666         PerlMem_free(unixified);
7667         PerlMem_free(unixwild);
7668         return 1;
7669       }
7670     }
7671     /* First off, back up over constant elements at end of path */
7672     if (dirs) {
7673       for (front = end ; front >= base; front--)
7674          if (*front == '/' && !dirs--) { front++; break; }
7675     }
7676     lcres = PerlMem_malloc(VMS_MAXRSS);
7677     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
7678     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7679          cp1++,cp2++) {
7680             if (!decc_efs_case_preserve) {
7681                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
7682             }
7683             else {
7684                 *cp2 = *cp1;
7685             }
7686     }
7687     if (cp1 != '\0') {
7688         PerlMem_free(tpl);
7689         PerlMem_free(unixified);
7690         PerlMem_free(unixwild);
7691         PerlMem_free(lcres);
7692         return 0;  /* Path too long. */
7693     }
7694     lcend = cp2;
7695     *cp2 = '\0';  /* Pick up with memcpy later */
7696     lcfront = lcres + (front - base);
7697     /* Now skip over each ellipsis and try to match the path in front of it. */
7698     while (ells--) {
7699       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7700         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
7701             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
7702       if (cp1 < template) break; /* template started with an ellipsis */
7703       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7704         ellipsis = cp1; continue;
7705       }
7706       wilddsc.dsc$a_pointer = tpl;
7707       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7708       nextell = cp1;
7709       for (segdirs = 0, cp2 = tpl;
7710            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7711            cp1++, cp2++) {
7712          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7713          else {
7714             if (!decc_efs_case_preserve) {
7715               *cp2 = _tolower(*cp1);  /* else lowercase for match */
7716             }
7717             else {
7718               *cp2 = *cp1;  /* else preserve case for match */
7719             }
7720          }
7721          if (*cp2 == '/') segdirs++;
7722       }
7723       if (cp1 != ellipsis - 1) {
7724           PerlMem_free(tpl);
7725           PerlMem_free(unixified);
7726           PerlMem_free(unixwild);
7727           PerlMem_free(lcres);
7728           return 0; /* Path too long */
7729       }
7730       /* Back up at least as many dirs as in template before matching */
7731       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7732         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7733       for (match = 0; cp1 > lcres;) {
7734         resdsc.dsc$a_pointer = cp1;
7735         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7736           match++;
7737           if (match == 1) lcfront = cp1;
7738         }
7739         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7740       }
7741       if (!match) {
7742         PerlMem_free(tpl);
7743         PerlMem_free(unixified);
7744         PerlMem_free(unixwild);
7745         PerlMem_free(lcres);
7746         return 0;  /* Can't find prefix ??? */
7747       }
7748       if (match > 1 && opts & 1) {
7749         /* This ... wildcard could cover more than one set of dirs (i.e.
7750          * a set of similar dir names is repeated).  If the template
7751          * contains more than 1 ..., upstream elements could resolve the
7752          * ambiguity, but it's not worth a full backtracking setup here.
7753          * As a quick heuristic, clip off the current default directory
7754          * if it's present to find the trimmed spec, else use the
7755          * shortest string that this ... could cover.
7756          */
7757         char def[NAM$C_MAXRSS+1], *st;
7758
7759         if (getcwd(def, sizeof def,0) == NULL) {
7760             Safefree(unixified);
7761             Safefree(unixwild);
7762             Safefree(lcres);
7763             Safefree(tpl);
7764             return 0;
7765         }
7766         if (!decc_efs_case_preserve) {
7767           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7768             if (_tolower(*cp1) != _tolower(*cp2)) break;
7769         }
7770         segdirs = dirs - totells;  /* Min # of dirs we must have left */
7771         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7772         if (*cp1 == '\0' && *cp2 == '/') {
7773           memmove(fspec,cp2+1,end - cp2);
7774           PerlMem_free(tpl);
7775           PerlMem_free(unixified);
7776           PerlMem_free(unixwild);
7777           PerlMem_free(lcres);
7778           return 1;
7779         }
7780         /* Nope -- stick with lcfront from above and keep going. */
7781       }
7782     }
7783     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7784     PerlMem_free(tpl);
7785     PerlMem_free(unixified);
7786     PerlMem_free(unixwild);
7787     PerlMem_free(lcres);
7788     return 1;
7789     ellipsis = nextell;
7790   }
7791
7792 }  /* end of trim_unixpath() */
7793 /*}}}*/
7794
7795
7796 /*
7797  *  VMS readdir() routines.
7798  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7799  *
7800  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
7801  *  Minor modifications to original routines.
7802  */
7803
7804 /* readdir may have been redefined by reentr.h, so make sure we get
7805  * the local version for what we do here.
7806  */
7807 #ifdef readdir
7808 # undef readdir
7809 #endif
7810 #if !defined(PERL_IMPLICIT_CONTEXT)
7811 # define readdir Perl_readdir
7812 #else
7813 # define readdir(a) Perl_readdir(aTHX_ a)
7814 #endif
7815
7816     /* Number of elements in vms_versions array */
7817 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
7818
7819 /*
7820  *  Open a directory, return a handle for later use.
7821  */
7822 /*{{{ DIR *opendir(char*name) */
7823 DIR *
7824 Perl_opendir(pTHX_ const char *name)
7825 {
7826     DIR *dd;
7827     char *dir;
7828     Stat_t sb;
7829     int unix_flag;
7830
7831     unix_flag = 0;
7832     if (decc_efs_charset) {
7833         unix_flag = is_unix_filespec(name);
7834     }
7835
7836     Newx(dir, VMS_MAXRSS, char);
7837     if (do_tovmspath(name,dir,0) == NULL) {
7838       Safefree(dir);
7839       return NULL;
7840     }
7841     /* Check access before stat; otherwise stat does not
7842      * accurately report whether it's a directory.
7843      */
7844     if (!cando_by_name(S_IRUSR,0,dir)) {
7845       /* cando_by_name has already set errno */
7846       Safefree(dir);
7847       return NULL;
7848     }
7849     if (flex_stat(dir,&sb) == -1) return NULL;
7850     if (!S_ISDIR(sb.st_mode)) {
7851       Safefree(dir);
7852       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
7853       return NULL;
7854     }
7855     /* Get memory for the handle, and the pattern. */
7856     Newx(dd,1,DIR);
7857     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7858
7859     /* Fill in the fields; mainly playing with the descriptor. */
7860     sprintf(dd->pattern, "%s*.*",dir);
7861     Safefree(dir);
7862     dd->context = 0;
7863     dd->count = 0;
7864     dd->flags = 0;
7865     if (unix_flag)
7866         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
7867     dd->pat.dsc$a_pointer = dd->pattern;
7868     dd->pat.dsc$w_length = strlen(dd->pattern);
7869     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7870     dd->pat.dsc$b_class = DSC$K_CLASS_S;
7871 #if defined(USE_ITHREADS)
7872     Newx(dd->mutex,1,perl_mutex);
7873     MUTEX_INIT( (perl_mutex *) dd->mutex );
7874 #else
7875     dd->mutex = NULL;
7876 #endif
7877
7878     return dd;
7879 }  /* end of opendir() */
7880 /*}}}*/
7881
7882 /*
7883  *  Set the flag to indicate we want versions or not.
7884  */
7885 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7886 void
7887 vmsreaddirversions(DIR *dd, int flag)
7888 {
7889     if (flag)
7890         dd->flags |= PERL_VMSDIR_M_VERSIONS;
7891     else
7892         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
7893 }
7894 /*}}}*/
7895
7896 /*
7897  *  Free up an opened directory.
7898  */
7899 /*{{{ void closedir(DIR *dd)*/
7900 void
7901 Perl_closedir(DIR *dd)
7902 {
7903     int sts;
7904
7905     sts = lib$find_file_end(&dd->context);
7906     Safefree(dd->pattern);
7907 #if defined(USE_ITHREADS)
7908     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7909     Safefree(dd->mutex);
7910 #endif
7911     Safefree(dd);
7912 }
7913 /*}}}*/
7914
7915 /*
7916  *  Collect all the version numbers for the current file.
7917  */
7918 static void
7919 collectversions(pTHX_ DIR *dd)
7920 {
7921     struct dsc$descriptor_s     pat;
7922     struct dsc$descriptor_s     res;
7923     struct dirent *e;
7924     char *p, *text, *buff;
7925     int i;
7926     unsigned long context, tmpsts;
7927
7928     /* Convenient shorthand. */
7929     e = &dd->entry;
7930
7931     /* Add the version wildcard, ignoring the "*.*" put on before */
7932     i = strlen(dd->pattern);
7933     Newx(text,i + e->d_namlen + 3,char);
7934     strcpy(text, dd->pattern);
7935     sprintf(&text[i - 3], "%s;*", e->d_name);
7936
7937     /* Set up the pattern descriptor. */
7938     pat.dsc$a_pointer = text;
7939     pat.dsc$w_length = i + e->d_namlen - 1;
7940     pat.dsc$b_dtype = DSC$K_DTYPE_T;
7941     pat.dsc$b_class = DSC$K_CLASS_S;
7942
7943     /* Set up result descriptor. */
7944     Newx(buff, VMS_MAXRSS, char);
7945     res.dsc$a_pointer = buff;
7946     res.dsc$w_length = VMS_MAXRSS - 1;
7947     res.dsc$b_dtype = DSC$K_DTYPE_T;
7948     res.dsc$b_class = DSC$K_CLASS_S;
7949
7950     /* Read files, collecting versions. */
7951     for (context = 0, e->vms_verscount = 0;
7952          e->vms_verscount < VERSIZE(e);
7953          e->vms_verscount++) {
7954         unsigned long rsts;
7955         unsigned long flags = 0;
7956
7957 #ifdef VMS_LONGNAME_SUPPORT
7958         flags = LIB$M_FIL_LONG_NAMES;
7959 #endif
7960         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
7961         if (tmpsts == RMS$_NMF || context == 0) break;
7962         _ckvmssts(tmpsts);
7963         buff[VMS_MAXRSS - 1] = '\0';
7964         if ((p = strchr(buff, ';')))
7965             e->vms_versions[e->vms_verscount] = atoi(p + 1);
7966         else
7967             e->vms_versions[e->vms_verscount] = -1;
7968     }
7969
7970     _ckvmssts(lib$find_file_end(&context));
7971     Safefree(text);
7972     Safefree(buff);
7973
7974 }  /* end of collectversions() */
7975
7976 /*
7977  *  Read the next entry from the directory.
7978  */
7979 /*{{{ struct dirent *readdir(DIR *dd)*/
7980 struct dirent *
7981 Perl_readdir(pTHX_ DIR *dd)
7982 {
7983     struct dsc$descriptor_s     res;
7984     char *p, *buff;
7985     unsigned long int tmpsts;
7986     unsigned long rsts;
7987     unsigned long flags = 0;
7988     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7989     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7990
7991     /* Set up result descriptor, and get next file. */
7992     Newx(buff, VMS_MAXRSS, char);
7993     res.dsc$a_pointer = buff;
7994     res.dsc$w_length = VMS_MAXRSS - 1;
7995     res.dsc$b_dtype = DSC$K_DTYPE_T;
7996     res.dsc$b_class = DSC$K_CLASS_S;
7997
7998 #ifdef VMS_LONGNAME_SUPPORT
7999     flags = LIB$M_FIL_LONG_NAMES;
8000 #endif
8001
8002     tmpsts = lib$find_file
8003         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8004     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8005     if (!(tmpsts & 1)) {
8006       set_vaxc_errno(tmpsts);
8007       switch (tmpsts) {
8008         case RMS$_PRV:
8009           set_errno(EACCES); break;
8010         case RMS$_DEV:
8011           set_errno(ENODEV); break;
8012         case RMS$_DIR:
8013           set_errno(ENOTDIR); break;
8014         case RMS$_FNF: case RMS$_DNF:
8015           set_errno(ENOENT); break;
8016         default:
8017           set_errno(EVMSERR);
8018       }
8019       Safefree(buff);
8020       return NULL;
8021     }
8022     dd->count++;
8023     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8024     if (!decc_efs_case_preserve) {
8025       buff[VMS_MAXRSS - 1] = '\0';
8026       for (p = buff; *p; p++) *p = _tolower(*p);
8027     }
8028     else {
8029       /* we don't want to force to lowercase, just null terminate */
8030       buff[res.dsc$w_length] = '\0';
8031     }
8032     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8033     *p = '\0';
8034
8035     /* Skip any directory component and just copy the name. */
8036     sts = vms_split_path
8037        (aTHX_ buff,
8038         &v_spec,
8039         &v_len,
8040         &r_spec,
8041         &r_len,
8042         &d_spec,
8043         &d_len,
8044         &n_spec,
8045         &n_len,
8046         &e_spec,
8047         &e_len,
8048         &vs_spec,
8049         &vs_len);
8050
8051     /* Drop NULL extensions on UNIX file specification */
8052     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8053         (e_len == 1) && decc_readdir_dropdotnotype)) {
8054         e_len = 0;
8055         e_spec[0] = '\0';
8056     }
8057
8058     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8059     dd->entry.d_name[n_len + e_len] = '\0';
8060     dd->entry.d_namlen = strlen(dd->entry.d_name);
8061
8062     /* Convert the filename to UNIX format if needed */
8063     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8064
8065         /* Translate the encoded characters. */
8066         /* Fixme: unicode handling could result in embedded 0 characters */
8067         if (strchr(dd->entry.d_name, '^') != NULL) {
8068             char new_name[256];
8069             char * q;
8070             int cnt;
8071             p = dd->entry.d_name;
8072             q = new_name;
8073             while (*p != 0) {
8074                 int x, y;
8075                 x = copy_expand_vms_filename_escape(q, p, &y);
8076                 p += x;
8077                 q += y;
8078                 /* fix-me */
8079                 /* if y > 1, then this is a wide file specification */
8080                 /* Wide file specifications need to be passed in Perl */
8081                 /* counted strings apparently with a unicode flag */
8082             }
8083             *q = 0;
8084             strcpy(dd->entry.d_name, new_name);
8085         }
8086     }
8087
8088     dd->entry.vms_verscount = 0;
8089     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8090     Safefree(buff);
8091     return &dd->entry;
8092
8093 }  /* end of readdir() */
8094 /*}}}*/
8095
8096 /*
8097  *  Read the next entry from the directory -- thread-safe version.
8098  */
8099 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8100 int
8101 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8102 {
8103     int retval;
8104
8105     MUTEX_LOCK( (perl_mutex *) dd->mutex );
8106
8107     entry = readdir(dd);
8108     *result = entry;
8109     retval = ( *result == NULL ? errno : 0 );
8110
8111     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8112
8113     return retval;
8114
8115 }  /* end of readdir_r() */
8116 /*}}}*/
8117
8118 /*
8119  *  Return something that can be used in a seekdir later.
8120  */
8121 /*{{{ long telldir(DIR *dd)*/
8122 long
8123 Perl_telldir(DIR *dd)
8124 {
8125     return dd->count;
8126 }
8127 /*}}}*/
8128
8129 /*
8130  *  Return to a spot where we used to be.  Brute force.
8131  */
8132 /*{{{ void seekdir(DIR *dd,long count)*/
8133 void
8134 Perl_seekdir(pTHX_ DIR *dd, long count)
8135 {
8136     int old_flags;
8137
8138     /* If we haven't done anything yet... */
8139     if (dd->count == 0)
8140         return;
8141
8142     /* Remember some state, and clear it. */
8143     old_flags = dd->flags;
8144     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8145     _ckvmssts(lib$find_file_end(&dd->context));
8146     dd->context = 0;
8147
8148     /* The increment is in readdir(). */
8149     for (dd->count = 0; dd->count < count; )
8150         readdir(dd);
8151
8152     dd->flags = old_flags;
8153
8154 }  /* end of seekdir() */
8155 /*}}}*/
8156
8157 /* VMS subprocess management
8158  *
8159  * my_vfork() - just a vfork(), after setting a flag to record that
8160  * the current script is trying a Unix-style fork/exec.
8161  *
8162  * vms_do_aexec() and vms_do_exec() are called in response to the
8163  * perl 'exec' function.  If this follows a vfork call, then they
8164  * call out the regular perl routines in doio.c which do an
8165  * execvp (for those who really want to try this under VMS).
8166  * Otherwise, they do exactly what the perl docs say exec should
8167  * do - terminate the current script and invoke a new command
8168  * (See below for notes on command syntax.)
8169  *
8170  * do_aspawn() and do_spawn() implement the VMS side of the perl
8171  * 'system' function.
8172  *
8173  * Note on command arguments to perl 'exec' and 'system': When handled
8174  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8175  * are concatenated to form a DCL command string.  If the first arg
8176  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8177  * the command string is handed off to DCL directly.  Otherwise,
8178  * the first token of the command is taken as the filespec of an image
8179  * to run.  The filespec is expanded using a default type of '.EXE' and
8180  * the process defaults for device, directory, etc., and if found, the resultant
8181  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8182  * the command string as parameters.  This is perhaps a bit complicated,
8183  * but I hope it will form a happy medium between what VMS folks expect
8184  * from lib$spawn and what Unix folks expect from exec.
8185  */
8186
8187 static int vfork_called;
8188
8189 /*{{{int my_vfork()*/
8190 int
8191 my_vfork()
8192 {
8193   vfork_called++;
8194   return vfork();
8195 }
8196 /*}}}*/
8197
8198
8199 static void
8200 vms_execfree(struct dsc$descriptor_s *vmscmd)
8201 {
8202   if (vmscmd) {
8203       if (vmscmd->dsc$a_pointer) {
8204           PerlMem_free(vmscmd->dsc$a_pointer);
8205       }
8206       PerlMem_free(vmscmd);
8207   }
8208 }
8209
8210 static char *
8211 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8212 {
8213   char *junk, *tmps = Nullch;
8214   register size_t cmdlen = 0;
8215   size_t rlen;
8216   register SV **idx;
8217   STRLEN n_a;
8218
8219   idx = mark;
8220   if (really) {
8221     tmps = SvPV(really,rlen);
8222     if (*tmps) {
8223       cmdlen += rlen + 1;
8224       idx++;
8225     }
8226   }
8227
8228   for (idx++; idx <= sp; idx++) {
8229     if (*idx) {
8230       junk = SvPVx(*idx,rlen);
8231       cmdlen += rlen ? rlen + 1 : 0;
8232     }
8233   }
8234   Newx(PL_Cmd, cmdlen+1, char);
8235
8236   if (tmps && *tmps) {
8237     strcpy(PL_Cmd,tmps);
8238     mark++;
8239   }
8240   else *PL_Cmd = '\0';
8241   while (++mark <= sp) {
8242     if (*mark) {
8243       char *s = SvPVx(*mark,n_a);
8244       if (!*s) continue;
8245       if (*PL_Cmd) strcat(PL_Cmd," ");
8246       strcat(PL_Cmd,s);
8247     }
8248   }
8249   return PL_Cmd;
8250
8251 }  /* end of setup_argstr() */
8252
8253
8254 static unsigned long int
8255 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8256                    struct dsc$descriptor_s **pvmscmd)
8257 {
8258   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8259   char image_name[NAM$C_MAXRSS+1];
8260   char image_argv[NAM$C_MAXRSS+1];
8261   $DESCRIPTOR(defdsc,".EXE");
8262   $DESCRIPTOR(defdsc2,".");
8263   $DESCRIPTOR(resdsc,resspec);
8264   struct dsc$descriptor_s *vmscmd;
8265   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8266   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8267   register char *s, *rest, *cp, *wordbreak;
8268   char * cmd;
8269   int cmdlen;
8270   register int isdcl;
8271
8272   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8273   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8274
8275   /* Make a copy for modification */
8276   cmdlen = strlen(incmd);
8277   cmd = PerlMem_malloc(cmdlen+1);
8278   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8279   strncpy(cmd, incmd, cmdlen);
8280   cmd[cmdlen] = 0;
8281   image_name[0] = 0;
8282   image_argv[0] = 0;
8283
8284   vmscmd->dsc$a_pointer = NULL;
8285   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
8286   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
8287   vmscmd->dsc$w_length = 0;
8288   if (pvmscmd) *pvmscmd = vmscmd;
8289
8290   if (suggest_quote) *suggest_quote = 0;
8291
8292   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8293     PerlMem_free(cmd);
8294     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
8295   }
8296
8297   s = cmd;
8298
8299   while (*s && isspace(*s)) s++;
8300
8301   if (*s == '@' || *s == '$') {
8302     vmsspec[0] = *s;  rest = s + 1;
8303     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8304   }
8305   else { cp = vmsspec; rest = s; }
8306   if (*rest == '.' || *rest == '/') {
8307     char *cp2;
8308     for (cp2 = resspec;
8309          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8310          rest++, cp2++) *cp2 = *rest;
8311     *cp2 = '\0';
8312     if (do_tovmsspec(resspec,cp,0)) {
8313       s = vmsspec;
8314       if (*rest) {
8315         for (cp2 = vmsspec + strlen(vmsspec);
8316              *rest && cp2 - vmsspec < sizeof vmsspec;
8317              rest++, cp2++) *cp2 = *rest;
8318         *cp2 = '\0';
8319       }
8320     }
8321   }
8322   /* Intuit whether verb (first word of cmd) is a DCL command:
8323    *   - if first nonspace char is '@', it's a DCL indirection
8324    * otherwise
8325    *   - if verb contains a filespec separator, it's not a DCL command
8326    *   - if it doesn't, caller tells us whether to default to a DCL
8327    *     command, or to a local image unless told it's DCL (by leading '$')
8328    */
8329   if (*s == '@') {
8330       isdcl = 1;
8331       if (suggest_quote) *suggest_quote = 1;
8332   } else {
8333     register char *filespec = strpbrk(s,":<[.;");
8334     rest = wordbreak = strpbrk(s," \"\t/");
8335     if (!wordbreak) wordbreak = s + strlen(s);
8336     if (*s == '$') check_img = 0;
8337     if (filespec && (filespec < wordbreak)) isdcl = 0;
8338     else isdcl = !check_img;
8339   }
8340
8341   if (!isdcl) {
8342     int rsts;
8343     imgdsc.dsc$a_pointer = s;
8344     imgdsc.dsc$w_length = wordbreak - s;
8345     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8346     if (!(retsts&1)) {
8347         _ckvmssts(lib$find_file_end(&cxt));
8348         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8349       if (!(retsts & 1) && *s == '$') {
8350         _ckvmssts(lib$find_file_end(&cxt));
8351         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8352         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8353         if (!(retsts&1)) {
8354           _ckvmssts(lib$find_file_end(&cxt));
8355           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8356         }
8357       }
8358     }
8359     _ckvmssts(lib$find_file_end(&cxt));
8360
8361     if (retsts & 1) {
8362       FILE *fp;
8363       s = resspec;
8364       while (*s && !isspace(*s)) s++;
8365       *s = '\0';
8366
8367       /* check that it's really not DCL with no file extension */
8368       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8369       if (fp) {
8370         char b[256] = {0,0,0,0};
8371         read(fileno(fp), b, 256);
8372         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
8373         if (isdcl) {
8374           int shebang_len;
8375
8376           /* Check for script */
8377           shebang_len = 0;
8378           if ((b[0] == '#') && (b[1] == '!'))
8379              shebang_len = 2;
8380 #ifdef ALTERNATE_SHEBANG
8381           else {
8382             shebang_len = strlen(ALTERNATE_SHEBANG);
8383             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
8384               char * perlstr;
8385                 perlstr = strstr("perl",b);
8386                 if (perlstr == NULL)
8387                   shebang_len = 0;
8388             }
8389             else
8390               shebang_len = 0;
8391           }
8392 #endif
8393
8394           if (shebang_len > 0) {
8395           int i;
8396           int j;
8397           char tmpspec[NAM$C_MAXRSS + 1];
8398
8399             i = shebang_len;
8400              /* Image is following after white space */
8401             /*--------------------------------------*/
8402             while (isprint(b[i]) && isspace(b[i]))
8403                 i++;
8404
8405             j = 0;
8406             while (isprint(b[i]) && !isspace(b[i])) {
8407                 tmpspec[j++] = b[i++];
8408                 if (j >= NAM$C_MAXRSS)
8409                    break;
8410             }
8411             tmpspec[j] = '\0';
8412
8413              /* There may be some default parameters to the image */
8414             /*---------------------------------------------------*/
8415             j = 0;
8416             while (isprint(b[i])) {
8417                 image_argv[j++] = b[i++];
8418                 if (j >= NAM$C_MAXRSS)
8419                    break;
8420             }
8421             while ((j > 0) && !isprint(image_argv[j-1]))
8422                 j--;
8423             image_argv[j] = 0;
8424
8425             /* It will need to be converted to VMS format and validated */
8426             if (tmpspec[0] != '\0') {
8427               char * iname;
8428
8429                /* Try to find the exact program requested to be run */
8430               /*---------------------------------------------------*/
8431               iname = do_rmsexpand
8432                   (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8433               if (iname != NULL) {
8434                 if (cando_by_name(S_IXUSR,0,image_name)) {
8435                   /* MCR prefix needed */
8436                   isdcl = 0;
8437                 }
8438                 else {
8439                    /* Try again with a null type */
8440                   /*----------------------------*/
8441                   iname = do_rmsexpand
8442                     (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8443                   if (iname != NULL) {
8444                     if (cando_by_name(S_IXUSR,0,image_name)) {
8445                       /* MCR prefix needed */
8446                       isdcl = 0;
8447                     }
8448                   }
8449                 }
8450
8451                  /* Did we find the image to run the script? */
8452                 /*------------------------------------------*/
8453                 if (isdcl) {
8454                   char *tchr;
8455
8456                    /* Assume DCL or foreign command exists */
8457                   /*--------------------------------------*/
8458                   tchr = strrchr(tmpspec, '/');
8459                   if (tchr != NULL) {
8460                     tchr++;
8461                   }
8462                   else {
8463                     tchr = tmpspec;
8464                   }
8465                   strcpy(image_name, tchr);
8466                 }
8467               }
8468             }
8469           }
8470         }
8471         fclose(fp);
8472       }
8473       if (check_img && isdcl) return RMS$_FNF;
8474
8475       if (cando_by_name(S_IXUSR,0,resspec)) {
8476         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
8477         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
8478         if (!isdcl) {
8479             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8480             if (image_name[0] != 0) {
8481                 strcat(vmscmd->dsc$a_pointer, image_name);
8482                 strcat(vmscmd->dsc$a_pointer, " ");
8483             }
8484         } else if (image_name[0] != 0) {
8485             strcpy(vmscmd->dsc$a_pointer, image_name);
8486             strcat(vmscmd->dsc$a_pointer, " ");
8487         } else {
8488             strcpy(vmscmd->dsc$a_pointer,"@");
8489         }
8490         if (suggest_quote) *suggest_quote = 1;
8491
8492         /* If there is an image name, use original command */
8493         if (image_name[0] == 0)
8494             strcat(vmscmd->dsc$a_pointer,resspec);
8495         else {
8496             rest = cmd;
8497             while (*rest && isspace(*rest)) rest++;
8498         }
8499
8500         if (image_argv[0] != 0) {
8501           strcat(vmscmd->dsc$a_pointer,image_argv);
8502           strcat(vmscmd->dsc$a_pointer, " ");
8503         }
8504         if (rest) {
8505            int rest_len;
8506            int vmscmd_len;
8507
8508            rest_len = strlen(rest);
8509            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8510            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8511               strcat(vmscmd->dsc$a_pointer,rest);
8512            else
8513              retsts = CLI$_BUFOVF;
8514         }
8515         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8516         PerlMem_free(cmd);
8517         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8518       }
8519       else
8520         retsts = RMS$_PRV;
8521     }
8522   }
8523   /* It's either a DCL command or we couldn't find a suitable image */
8524   vmscmd->dsc$w_length = strlen(cmd);
8525
8526   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
8527   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
8528   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
8529
8530   PerlMem_free(cmd);
8531
8532   /* check if it's a symbol (for quoting purposes) */
8533   if (suggest_quote && !*suggest_quote) {
8534     int iss;
8535     char equiv[LNM$C_NAMLENGTH];
8536     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8537     eqvdsc.dsc$a_pointer = equiv;
8538
8539     iss = lib$get_symbol(vmscmd,&eqvdsc);
8540     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8541   }
8542   if (!(retsts & 1)) {
8543     /* just hand off status values likely to be due to user error */
8544     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8545         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8546        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8547     else { _ckvmssts(retsts); }
8548   }
8549
8550   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8551
8552 }  /* end of setup_cmddsc() */
8553
8554
8555 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8556 bool
8557 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8558 {
8559 bool exec_sts;
8560 char * cmd;
8561
8562   if (sp > mark) {
8563     if (vfork_called) {           /* this follows a vfork - act Unixish */
8564       vfork_called--;
8565       if (vfork_called < 0) {
8566         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8567         vfork_called = 0;
8568       }
8569       else return do_aexec(really,mark,sp);
8570     }
8571                                            /* no vfork - act VMSish */
8572     cmd = setup_argstr(aTHX_ really,mark,sp);
8573     exec_sts = vms_do_exec(cmd);
8574     Safefree(cmd);  /* Clean up from setup_argstr() */
8575     return exec_sts;
8576   }
8577
8578   return FALSE;
8579 }  /* end of vms_do_aexec() */
8580 /*}}}*/
8581
8582 /* {{{bool vms_do_exec(char *cmd) */
8583 bool
8584 Perl_vms_do_exec(pTHX_ const char *cmd)
8585 {
8586   struct dsc$descriptor_s *vmscmd;
8587
8588   if (vfork_called) {             /* this follows a vfork - act Unixish */
8589     vfork_called--;
8590     if (vfork_called < 0) {
8591       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8592       vfork_called = 0;
8593     }
8594     else return do_exec(cmd);
8595   }
8596
8597   {                               /* no vfork - act VMSish */
8598     unsigned long int retsts;
8599
8600     TAINT_ENV();
8601     TAINT_PROPER("exec");
8602     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8603       retsts = lib$do_command(vmscmd);
8604
8605     switch (retsts) {
8606       case RMS$_FNF: case RMS$_DNF:
8607         set_errno(ENOENT); break;
8608       case RMS$_DIR:
8609         set_errno(ENOTDIR); break;
8610       case RMS$_DEV:
8611         set_errno(ENODEV); break;
8612       case RMS$_PRV:
8613         set_errno(EACCES); break;
8614       case RMS$_SYN:
8615         set_errno(EINVAL); break;
8616       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8617         set_errno(E2BIG); break;
8618       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8619         _ckvmssts(retsts); /* fall through */
8620       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8621         set_errno(EVMSERR);
8622     }
8623     set_vaxc_errno(retsts);
8624     if (ckWARN(WARN_EXEC)) {
8625       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8626              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8627     }
8628     vms_execfree(vmscmd);
8629   }
8630
8631   return FALSE;
8632
8633 }  /* end of vms_do_exec() */
8634 /*}}}*/
8635
8636 unsigned long int Perl_do_spawn(pTHX_ const char *);
8637
8638 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8639 unsigned long int
8640 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8641 {
8642 unsigned long int sts;
8643 char * cmd;
8644
8645   if (sp > mark) {
8646     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
8647     sts = do_spawn(cmd);
8648     /* pp_sys will clean up cmd */
8649     return sts;
8650   }
8651   return SS$_ABORT;
8652 }  /* end of do_aspawn() */
8653 /*}}}*/
8654
8655 /* {{{unsigned long int do_spawn(char *cmd) */
8656 unsigned long int
8657 Perl_do_spawn(pTHX_ const char *cmd)
8658 {
8659   unsigned long int sts, substs;
8660
8661   /* The caller of this routine expects to Safefree(PL_Cmd) */
8662   Newx(PL_Cmd,10,char);
8663
8664   TAINT_ENV();
8665   TAINT_PROPER("spawn");
8666   if (!cmd || !*cmd) {
8667     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8668     if (!(sts & 1)) {
8669       switch (sts) {
8670         case RMS$_FNF:  case RMS$_DNF:
8671           set_errno(ENOENT); break;
8672         case RMS$_DIR:
8673           set_errno(ENOTDIR); break;
8674         case RMS$_DEV:
8675           set_errno(ENODEV); break;
8676         case RMS$_PRV:
8677           set_errno(EACCES); break;
8678         case RMS$_SYN:
8679           set_errno(EINVAL); break;
8680         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8681           set_errno(E2BIG); break;
8682         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8683           _ckvmssts(sts); /* fall through */
8684         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8685           set_errno(EVMSERR);
8686       }
8687       set_vaxc_errno(sts);
8688       if (ckWARN(WARN_EXEC)) {
8689         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8690                     Strerror(errno));
8691       }
8692     }
8693     sts = substs;
8694   }
8695   else {
8696     PerlIO * fp;
8697     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8698     if (fp != NULL)
8699       my_pclose(fp);
8700   }
8701   return sts;
8702 }  /* end of do_spawn() */
8703 /*}}}*/
8704
8705
8706 static unsigned int *sockflags, sockflagsize;
8707
8708 /*
8709  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8710  * routines found in some versions of the CRTL can't deal with sockets.
8711  * We don't shim the other file open routines since a socket isn't
8712  * likely to be opened by a name.
8713  */
8714 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8715 FILE *my_fdopen(int fd, const char *mode)
8716 {
8717   FILE *fp = fdopen(fd, mode);
8718
8719   if (fp) {
8720     unsigned int fdoff = fd / sizeof(unsigned int);
8721     Stat_t sbuf; /* native stat; we don't need flex_stat */
8722     if (!sockflagsize || fdoff > sockflagsize) {
8723       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
8724       else           Newx  (sockflags,fdoff+2,unsigned int);
8725       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8726       sockflagsize = fdoff + 2;
8727     }
8728     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8729       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8730   }
8731   return fp;
8732
8733 }
8734 /*}}}*/
8735
8736
8737 /*
8738  * Clear the corresponding bit when the (possibly) socket stream is closed.
8739  * There still a small hole: we miss an implicit close which might occur
8740  * via freopen().  >> Todo
8741  */
8742 /*{{{ int my_fclose(FILE *fp)*/
8743 int my_fclose(FILE *fp) {
8744   if (fp) {
8745     unsigned int fd = fileno(fp);
8746     unsigned int fdoff = fd / sizeof(unsigned int);
8747
8748     if (sockflagsize && fdoff <= sockflagsize)
8749       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8750   }
8751   return fclose(fp);
8752 }
8753 /*}}}*/
8754
8755
8756 /*
8757  * A simple fwrite replacement which outputs itmsz*nitm chars without
8758  * introducing record boundaries every itmsz chars.
8759  * We are using fputs, which depends on a terminating null.  We may
8760  * well be writing binary data, so we need to accommodate not only
8761  * data with nulls sprinkled in the middle but also data with no null
8762  * byte at the end.
8763  */
8764 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8765 int
8766 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8767 {
8768   register char *cp, *end, *cpd, *data;
8769   register unsigned int fd = fileno(dest);
8770   register unsigned int fdoff = fd / sizeof(unsigned int);
8771   int retval;
8772   int bufsize = itmsz * nitm + 1;
8773
8774   if (fdoff < sockflagsize &&
8775       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8776     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8777     return nitm;
8778   }
8779
8780   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8781   memcpy( data, src, itmsz*nitm );
8782   data[itmsz*nitm] = '\0';
8783
8784   end = data + itmsz * nitm;
8785   retval = (int) nitm; /* on success return # items written */
8786
8787   cpd = data;
8788   while (cpd <= end) {
8789     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8790     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8791     if (cp < end)
8792       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8793     cpd = cp + 1;
8794   }
8795
8796   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8797   return retval;
8798
8799 }  /* end of my_fwrite() */
8800 /*}}}*/
8801
8802 /*{{{ int my_flush(FILE *fp)*/
8803 int
8804 Perl_my_flush(pTHX_ FILE *fp)
8805 {
8806     int res;
8807     if ((res = fflush(fp)) == 0 && fp) {
8808 #ifdef VMS_DO_SOCKETS
8809         Stat_t s;
8810         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8811 #endif
8812             res = fsync(fileno(fp));
8813     }
8814 /*
8815  * If the flush succeeded but set end-of-file, we need to clear
8816  * the error because our caller may check ferror().  BTW, this
8817  * probably means we just flushed an empty file.
8818  */
8819     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8820
8821     return res;
8822 }
8823 /*}}}*/
8824
8825 /*
8826  * Here are replacements for the following Unix routines in the VMS environment:
8827  *      getpwuid    Get information for a particular UIC or UID
8828  *      getpwnam    Get information for a named user
8829  *      getpwent    Get information for each user in the rights database
8830  *      setpwent    Reset search to the start of the rights database
8831  *      endpwent    Finish searching for users in the rights database
8832  *
8833  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8834  * (defined in pwd.h), which contains the following fields:-
8835  *      struct passwd {
8836  *              char        *pw_name;    Username (in lower case)
8837  *              char        *pw_passwd;  Hashed password
8838  *              unsigned int pw_uid;     UIC
8839  *              unsigned int pw_gid;     UIC group  number
8840  *              char        *pw_unixdir; Default device/directory (VMS-style)
8841  *              char        *pw_gecos;   Owner name
8842  *              char        *pw_dir;     Default device/directory (Unix-style)
8843  *              char        *pw_shell;   Default CLI name (eg. DCL)
8844  *      };
8845  * If the specified user does not exist, getpwuid and getpwnam return NULL.
8846  *
8847  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8848  * not the UIC member number (eg. what's returned by getuid()),
8849  * getpwuid() can accept either as input (if uid is specified, the caller's
8850  * UIC group is used), though it won't recognise gid=0.
8851  *
8852  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8853  * information about other users in your group or in other groups, respectively.
8854  * If the required privilege is not available, then these routines fill only
8855  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8856  * string).
8857  *
8858  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8859  */
8860
8861 /* sizes of various UAF record fields */
8862 #define UAI$S_USERNAME 12
8863 #define UAI$S_IDENT    31
8864 #define UAI$S_OWNER    31
8865 #define UAI$S_DEFDEV   31
8866 #define UAI$S_DEFDIR   63
8867 #define UAI$S_DEFCLI   31
8868 #define UAI$S_PWD       8
8869
8870 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
8871                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8872                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
8873
8874 static char __empty[]= "";
8875 static struct passwd __passwd_empty=
8876     {(char *) __empty, (char *) __empty, 0, 0,
8877      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8878 static int contxt= 0;
8879 static struct passwd __pwdcache;
8880 static char __pw_namecache[UAI$S_IDENT+1];
8881
8882 /*
8883  * This routine does most of the work extracting the user information.
8884  */
8885 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8886 {
8887     static struct {
8888         unsigned char length;
8889         char pw_gecos[UAI$S_OWNER+1];
8890     } owner;
8891     static union uicdef uic;
8892     static struct {
8893         unsigned char length;
8894         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8895     } defdev;
8896     static struct {
8897         unsigned char length;
8898         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8899     } defdir;
8900     static struct {
8901         unsigned char length;
8902         char pw_shell[UAI$S_DEFCLI+1];
8903     } defcli;
8904     static char pw_passwd[UAI$S_PWD+1];
8905
8906     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8907     struct dsc$descriptor_s name_desc;
8908     unsigned long int sts;
8909
8910     static struct itmlst_3 itmlst[]= {
8911         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
8912         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
8913         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
8914         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
8915         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
8916         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
8917         {0,                0,           NULL,    NULL}};
8918
8919     name_desc.dsc$w_length=  strlen(name);
8920     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8921     name_desc.dsc$b_class=   DSC$K_CLASS_S;
8922     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8923
8924 /*  Note that sys$getuai returns many fields as counted strings. */
8925     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8926     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8927       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8928     }
8929     else { _ckvmssts(sts); }
8930     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
8931
8932     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
8933     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8934     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8935     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8936     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8937     owner.pw_gecos[lowner]=            '\0';
8938     defdev.pw_dir[ldefdev+ldefdir]= '\0';
8939     defcli.pw_shell[ldefcli]=          '\0';
8940     if (valid_uic(uic)) {
8941         pwd->pw_uid= uic.uic$l_uic;
8942         pwd->pw_gid= uic.uic$v_group;
8943     }
8944     else
8945       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8946     pwd->pw_passwd=  pw_passwd;
8947     pwd->pw_gecos=   owner.pw_gecos;
8948     pwd->pw_dir=     defdev.pw_dir;
8949     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8950     pwd->pw_shell=   defcli.pw_shell;
8951     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8952         int ldir;
8953         ldir= strlen(pwd->pw_unixdir) - 1;
8954         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8955     }
8956     else
8957         strcpy(pwd->pw_unixdir, pwd->pw_dir);
8958     if (!decc_efs_case_preserve)
8959         __mystrtolower(pwd->pw_unixdir);
8960     return 1;
8961 }
8962
8963 /*
8964  * Get information for a named user.
8965 */
8966 /*{{{struct passwd *getpwnam(char *name)*/
8967 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8968 {
8969     struct dsc$descriptor_s name_desc;
8970     union uicdef uic;
8971     unsigned long int status, sts;
8972
8973     __pwdcache = __passwd_empty;
8974     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8975       /* We still may be able to determine pw_uid and pw_gid */
8976       name_desc.dsc$w_length=  strlen(name);
8977       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8978       name_desc.dsc$b_class=   DSC$K_CLASS_S;
8979       name_desc.dsc$a_pointer= (char *) name;
8980       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
8981         __pwdcache.pw_uid= uic.uic$l_uic;
8982         __pwdcache.pw_gid= uic.uic$v_group;
8983       }
8984       else {
8985         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8986           set_vaxc_errno(sts);
8987           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
8988           return NULL;
8989         }
8990         else { _ckvmssts(sts); }
8991       }
8992     }
8993     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8994     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8995     __pwdcache.pw_name= __pw_namecache;
8996     return &__pwdcache;
8997 }  /* end of my_getpwnam() */
8998 /*}}}*/
8999
9000 /*
9001  * Get information for a particular UIC or UID.
9002  * Called by my_getpwent with uid=-1 to list all users.
9003 */
9004 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9005 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9006 {
9007     const $DESCRIPTOR(name_desc,__pw_namecache);
9008     unsigned short lname;
9009     union uicdef uic;
9010     unsigned long int status;
9011
9012     if (uid == (unsigned int) -1) {
9013       do {
9014         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9015         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9016           set_vaxc_errno(status);
9017           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9018           my_endpwent();
9019           return NULL;
9020         }
9021         else { _ckvmssts(status); }
9022       } while (!valid_uic (uic));
9023     }
9024     else {
9025       uic.uic$l_uic= uid;
9026       if (!uic.uic$v_group)
9027         uic.uic$v_group= PerlProc_getgid();
9028       if (valid_uic(uic))
9029         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9030       else status = SS$_IVIDENT;
9031       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9032           status == RMS$_PRV) {
9033         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9034         return NULL;
9035       }
9036       else { _ckvmssts(status); }
9037     }
9038     __pw_namecache[lname]= '\0';
9039     __mystrtolower(__pw_namecache);
9040
9041     __pwdcache = __passwd_empty;
9042     __pwdcache.pw_name = __pw_namecache;
9043
9044 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9045     The identifier's value is usually the UIC, but it doesn't have to be,
9046     so if we can, we let fillpasswd update this. */
9047     __pwdcache.pw_uid =  uic.uic$l_uic;
9048     __pwdcache.pw_gid =  uic.uic$v_group;
9049
9050     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9051     return &__pwdcache;
9052
9053 }  /* end of my_getpwuid() */
9054 /*}}}*/
9055
9056 /*
9057  * Get information for next user.
9058 */
9059 /*{{{struct passwd *my_getpwent()*/
9060 struct passwd *Perl_my_getpwent(pTHX)
9061 {
9062     return (my_getpwuid((unsigned int) -1));
9063 }
9064 /*}}}*/
9065
9066 /*
9067  * Finish searching rights database for users.
9068 */
9069 /*{{{void my_endpwent()*/
9070 void Perl_my_endpwent(pTHX)
9071 {
9072     if (contxt) {
9073       _ckvmssts(sys$finish_rdb(&contxt));
9074       contxt= 0;
9075     }
9076 }
9077 /*}}}*/
9078
9079 #ifdef HOMEGROWN_POSIX_SIGNALS
9080   /* Signal handling routines, pulled into the core from POSIX.xs.
9081    *
9082    * We need these for threads, so they've been rolled into the core,
9083    * rather than left in POSIX.xs.
9084    *
9085    * (DRS, Oct 23, 1997)
9086    */
9087
9088   /* sigset_t is atomic under VMS, so these routines are easy */
9089 /*{{{int my_sigemptyset(sigset_t *) */
9090 int my_sigemptyset(sigset_t *set) {
9091     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9092     *set = 0; return 0;
9093 }
9094 /*}}}*/
9095
9096
9097 /*{{{int my_sigfillset(sigset_t *)*/
9098 int my_sigfillset(sigset_t *set) {
9099     int i;
9100     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9101     for (i = 0; i < NSIG; i++) *set |= (1 << i);
9102     return 0;
9103 }
9104 /*}}}*/
9105
9106
9107 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9108 int my_sigaddset(sigset_t *set, int sig) {
9109     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9110     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9111     *set |= (1 << (sig - 1));
9112     return 0;
9113 }
9114 /*}}}*/
9115
9116
9117 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9118 int my_sigdelset(sigset_t *set, int sig) {
9119     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9120     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9121     *set &= ~(1 << (sig - 1));
9122     return 0;
9123 }
9124 /*}}}*/
9125
9126
9127 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9128 int my_sigismember(sigset_t *set, int sig) {
9129     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9130     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9131     return *set & (1 << (sig - 1));
9132 }
9133 /*}}}*/
9134
9135
9136 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9137 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9138     sigset_t tempmask;
9139
9140     /* If set and oset are both null, then things are badly wrong. Bail out. */
9141     if ((oset == NULL) && (set == NULL)) {
9142       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9143       return -1;
9144     }
9145
9146     /* If set's null, then we're just handling a fetch. */
9147     if (set == NULL) {
9148         tempmask = sigblock(0);
9149     }
9150     else {
9151       switch (how) {
9152       case SIG_SETMASK:
9153         tempmask = sigsetmask(*set);
9154         break;
9155       case SIG_BLOCK:
9156         tempmask = sigblock(*set);
9157         break;
9158       case SIG_UNBLOCK:
9159         tempmask = sigblock(0);
9160         sigsetmask(*oset & ~tempmask);
9161         break;
9162       default:
9163         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9164         return -1;
9165       }
9166     }
9167
9168     /* Did they pass us an oset? If so, stick our holding mask into it */
9169     if (oset)
9170       *oset = tempmask;
9171
9172     return 0;
9173 }
9174 /*}}}*/
9175 #endif  /* HOMEGROWN_POSIX_SIGNALS */
9176
9177
9178 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9179  * my_utime(), and flex_stat(), all of which operate on UTC unless
9180  * VMSISH_TIMES is true.
9181  */
9182 /* method used to handle UTC conversions:
9183  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
9184  */
9185 static int gmtime_emulation_type;
9186 /* number of secs to add to UTC POSIX-style time to get local time */
9187 static long int utc_offset_secs;
9188
9189 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9190  * in vmsish.h.  #undef them here so we can call the CRTL routines
9191  * directly.
9192  */
9193 #undef gmtime
9194 #undef localtime
9195 #undef time
9196
9197
9198 /*
9199  * DEC C previous to 6.0 corrupts the behavior of the /prefix
9200  * qualifier with the extern prefix pragma.  This provisional
9201  * hack circumvents this prefix pragma problem in previous
9202  * precompilers.
9203  */
9204 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9205 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9206 #    pragma __extern_prefix save
9207 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
9208 #    define gmtime decc$__utctz_gmtime
9209 #    define localtime decc$__utctz_localtime
9210 #    define time decc$__utc_time
9211 #    pragma __extern_prefix restore
9212
9213      struct tm *gmtime(), *localtime();
9214
9215 #  endif
9216 #endif
9217
9218
9219 static time_t toutc_dst(time_t loc) {
9220   struct tm *rsltmp;
9221
9222   if ((rsltmp = localtime(&loc)) == NULL) return -1;
9223   loc -= utc_offset_secs;
9224   if (rsltmp->tm_isdst) loc -= 3600;
9225   return loc;
9226 }
9227 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9228        ((gmtime_emulation_type || my_time(NULL)), \
9229        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9230        ((secs) - utc_offset_secs))))
9231
9232 static time_t toloc_dst(time_t utc) {
9233   struct tm *rsltmp;
9234
9235   utc += utc_offset_secs;
9236   if ((rsltmp = localtime(&utc)) == NULL) return -1;
9237   if (rsltmp->tm_isdst) utc += 3600;
9238   return utc;
9239 }
9240 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9241        ((gmtime_emulation_type || my_time(NULL)), \
9242        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9243        ((secs) + utc_offset_secs))))
9244
9245 #ifndef RTL_USES_UTC
9246 /*
9247
9248     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
9249         DST starts on 1st sun of april      at 02:00  std time
9250             ends on last sun of october     at 02:00  dst time
9251     see the UCX management command reference, SET CONFIG TIMEZONE
9252     for formatting info.
9253
9254     No, it's not as general as it should be, but then again, NOTHING
9255     will handle UK times in a sensible way.
9256 */
9257
9258
9259 /*
9260     parse the DST start/end info:
9261     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9262 */
9263
9264 static char *
9265 tz_parse_startend(char *s, struct tm *w, int *past)
9266 {
9267     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9268     int ly, dozjd, d, m, n, hour, min, sec, j, k;
9269     time_t g;
9270
9271     if (!s)    return 0;
9272     if (!w) return 0;
9273     if (!past) return 0;
9274
9275     ly = 0;
9276     if (w->tm_year % 4        == 0) ly = 1;
9277     if (w->tm_year % 100      == 0) ly = 0;
9278     if (w->tm_year+1900 % 400 == 0) ly = 1;
9279     if (ly) dinm[1]++;
9280
9281     dozjd = isdigit(*s);
9282     if (*s == 'J' || *s == 'j' || dozjd) {
9283         if (!dozjd && !isdigit(*++s)) return 0;
9284         d = *s++ - '0';
9285         if (isdigit(*s)) {
9286             d = d*10 + *s++ - '0';
9287             if (isdigit(*s)) {
9288                 d = d*10 + *s++ - '0';
9289             }
9290         }
9291         if (d == 0) return 0;
9292         if (d > 366) return 0;
9293         d--;
9294         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
9295         g = d * 86400;
9296         dozjd = 1;
9297     } else if (*s == 'M' || *s == 'm') {
9298         if (!isdigit(*++s)) return 0;
9299         m = *s++ - '0';
9300         if (isdigit(*s)) m = 10*m + *s++ - '0';
9301         if (*s != '.') return 0;
9302         if (!isdigit(*++s)) return 0;
9303         n = *s++ - '0';
9304         if (n < 1 || n > 5) return 0;
9305         if (*s != '.') return 0;
9306         if (!isdigit(*++s)) return 0;
9307         d = *s++ - '0';
9308         if (d > 6) return 0;
9309     }
9310
9311     if (*s == '/') {
9312         if (!isdigit(*++s)) return 0;
9313         hour = *s++ - '0';
9314         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9315         if (*s == ':') {
9316             if (!isdigit(*++s)) return 0;
9317             min = *s++ - '0';
9318             if (isdigit(*s)) min = 10*min + *s++ - '0';
9319             if (*s == ':') {
9320                 if (!isdigit(*++s)) return 0;
9321                 sec = *s++ - '0';
9322                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9323             }
9324         }
9325     } else {
9326         hour = 2;
9327         min = 0;
9328         sec = 0;
9329     }
9330
9331     if (dozjd) {
9332         if (w->tm_yday < d) goto before;
9333         if (w->tm_yday > d) goto after;
9334     } else {
9335         if (w->tm_mon+1 < m) goto before;
9336         if (w->tm_mon+1 > m) goto after;
9337
9338         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
9339         k = d - j; /* mday of first d */
9340         if (k <= 0) k += 7;
9341         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
9342         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9343         if (w->tm_mday < k) goto before;
9344         if (w->tm_mday > k) goto after;
9345     }
9346
9347     if (w->tm_hour < hour) goto before;
9348     if (w->tm_hour > hour) goto after;
9349     if (w->tm_min  < min)  goto before;
9350     if (w->tm_min  > min)  goto after;
9351     if (w->tm_sec  < sec)  goto before;
9352     goto after;
9353
9354 before:
9355     *past = 0;
9356     return s;
9357 after:
9358     *past = 1;
9359     return s;
9360 }
9361
9362
9363
9364
9365 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
9366
9367 static char *
9368 tz_parse_offset(char *s, int *offset)
9369 {
9370     int hour = 0, min = 0, sec = 0;
9371     int neg = 0;
9372     if (!s) return 0;
9373     if (!offset) return 0;
9374
9375     if (*s == '-') {neg++; s++;}
9376     if (*s == '+') s++;
9377     if (!isdigit(*s)) return 0;
9378     hour = *s++ - '0';
9379     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
9380     if (hour > 24) return 0;
9381     if (*s == ':') {
9382         if (!isdigit(*++s)) return 0;
9383         min = *s++ - '0';
9384         if (isdigit(*s)) min = min*10 + (*s++ - '0');
9385         if (min > 59) return 0;
9386         if (*s == ':') {
9387             if (!isdigit(*++s)) return 0;
9388             sec = *s++ - '0';
9389             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
9390             if (sec > 59) return 0;
9391         }
9392     }
9393
9394     *offset = (hour*60+min)*60 + sec;
9395     if (neg) *offset = -*offset;
9396     return s;
9397 }
9398
9399 /*
9400     input time is w, whatever type of time the CRTL localtime() uses.
9401     sets dst, the zone, and the gmtoff (seconds)
9402
9403     caches the value of TZ and UCX$TZ env variables; note that
9404     my_setenv looks for these and sets a flag if they're changed
9405     for efficiency.
9406
9407     We have to watch out for the "australian" case (dst starts in
9408     october, ends in april)...flagged by "reverse" and checked by
9409     scanning through the months of the previous year.
9410
9411 */
9412
9413 static int
9414 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
9415 {
9416     time_t when;
9417     struct tm *w2;
9418     char *s,*s2;
9419     char *dstzone, *tz, *s_start, *s_end;
9420     int std_off, dst_off, isdst;
9421     int y, dststart, dstend;
9422     static char envtz[1025];  /* longer than any logical, symbol, ... */
9423     static char ucxtz[1025];
9424     static char reversed = 0;
9425
9426     if (!w) return 0;
9427
9428     if (tz_updated) {
9429         tz_updated = 0;
9430         reversed = -1;  /* flag need to check  */
9431         envtz[0] = ucxtz[0] = '\0';
9432         tz = my_getenv("TZ",0);
9433         if (tz) strcpy(envtz, tz);
9434         tz = my_getenv("UCX$TZ",0);
9435         if (tz) strcpy(ucxtz, tz);
9436         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
9437     }
9438     tz = envtz;
9439     if (!*tz) tz = ucxtz;
9440
9441     s = tz;
9442     while (isalpha(*s)) s++;
9443     s = tz_parse_offset(s, &std_off);
9444     if (!s) return 0;
9445     if (!*s) {                  /* no DST, hurray we're done! */
9446         isdst = 0;
9447         goto done;
9448     }
9449
9450     dstzone = s;
9451     while (isalpha(*s)) s++;
9452     s2 = tz_parse_offset(s, &dst_off);
9453     if (s2) {
9454         s = s2;
9455     } else {
9456         dst_off = std_off - 3600;
9457     }
9458
9459     if (!*s) {      /* default dst start/end?? */
9460         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
9461             s = strchr(ucxtz,',');
9462         }
9463         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
9464     }
9465     if (*s != ',') return 0;
9466
9467     when = *w;
9468     when = _toutc(when);      /* convert to utc */
9469     when = when - std_off;    /* convert to pseudolocal time*/
9470
9471     w2 = localtime(&when);
9472     y = w2->tm_year;
9473     s_start = s+1;
9474     s = tz_parse_startend(s_start,w2,&dststart);
9475     if (!s) return 0;
9476     if (*s != ',') return 0;
9477
9478     when = *w;
9479     when = _toutc(when);      /* convert to utc */
9480     when = when - dst_off;    /* convert to pseudolocal time*/
9481     w2 = localtime(&when);
9482     if (w2->tm_year != y) {   /* spans a year, just check one time */
9483         when += dst_off - std_off;
9484         w2 = localtime(&when);
9485     }
9486     s_end = s+1;
9487     s = tz_parse_startend(s_end,w2,&dstend);
9488     if (!s) return 0;
9489
9490     if (reversed == -1) {  /* need to check if start later than end */
9491         int j, ds, de;
9492
9493         when = *w;
9494         if (when < 2*365*86400) {
9495             when += 2*365*86400;
9496         } else {
9497             when -= 365*86400;
9498         }
9499         w2 =localtime(&when);
9500         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
9501
9502         for (j = 0; j < 12; j++) {
9503             w2 =localtime(&when);
9504             tz_parse_startend(s_start,w2,&ds);
9505             tz_parse_startend(s_end,w2,&de);
9506             if (ds != de) break;
9507             when += 30*86400;
9508         }
9509         reversed = 0;
9510         if (de && !ds) reversed = 1;
9511     }
9512
9513     isdst = dststart && !dstend;
9514     if (reversed) isdst = dststart  || !dstend;
9515
9516 done:
9517     if (dst)    *dst = isdst;
9518     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9519     if (isdst)  tz = dstzone;
9520     if (zone) {
9521         while(isalpha(*tz))  *zone++ = *tz++;
9522         *zone = '\0';
9523     }
9524     return 1;
9525 }
9526
9527 #endif /* !RTL_USES_UTC */
9528
9529 /* my_time(), my_localtime(), my_gmtime()
9530  * By default traffic in UTC time values, using CRTL gmtime() or
9531  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9532  * Note: We need to use these functions even when the CRTL has working
9533  * UTC support, since they also handle C<use vmsish qw(times);>
9534  *
9535  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
9536  * Modified by Charles Bailey <bailey@newman.upenn.edu>
9537  */
9538
9539 /*{{{time_t my_time(time_t *timep)*/
9540 time_t Perl_my_time(pTHX_ time_t *timep)
9541 {
9542   time_t when;
9543   struct tm *tm_p;
9544
9545   if (gmtime_emulation_type == 0) {
9546     int dstnow;
9547     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
9548                               /* results of calls to gmtime() and localtime() */
9549                               /* for same &base */
9550
9551     gmtime_emulation_type++;
9552     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9553       char off[LNM$C_NAMLENGTH+1];;
9554
9555       gmtime_emulation_type++;
9556       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9557         gmtime_emulation_type++;
9558         utc_offset_secs = 0;
9559         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9560       }
9561       else { utc_offset_secs = atol(off); }
9562     }
9563     else { /* We've got a working gmtime() */
9564       struct tm gmt, local;
9565
9566       gmt = *tm_p;
9567       tm_p = localtime(&base);
9568       local = *tm_p;
9569       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
9570       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9571       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
9572       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
9573     }
9574   }
9575
9576   when = time(NULL);
9577 # ifdef VMSISH_TIME
9578 # ifdef RTL_USES_UTC
9579   if (VMSISH_TIME) when = _toloc(when);
9580 # else
9581   if (!VMSISH_TIME) when = _toutc(when);
9582 # endif
9583 # endif
9584   if (timep != NULL) *timep = when;
9585   return when;
9586
9587 }  /* end of my_time() */
9588 /*}}}*/
9589
9590
9591 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9592 struct tm *
9593 Perl_my_gmtime(pTHX_ const time_t *timep)
9594 {
9595   char *p;
9596   time_t when;
9597   struct tm *rsltmp;
9598
9599   if (timep == NULL) {
9600     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9601     return NULL;
9602   }
9603   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9604
9605   when = *timep;
9606 # ifdef VMSISH_TIME
9607   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9608 #  endif
9609 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
9610   return gmtime(&when);
9611 # else
9612   /* CRTL localtime() wants local time as input, so does no tz correction */
9613   rsltmp = localtime(&when);
9614   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
9615   return rsltmp;
9616 #endif
9617 }  /* end of my_gmtime() */
9618 /*}}}*/
9619
9620
9621 /*{{{struct tm *my_localtime(const time_t *timep)*/
9622 struct tm *
9623 Perl_my_localtime(pTHX_ const time_t *timep)
9624 {
9625   time_t when, whenutc;
9626   struct tm *rsltmp;
9627   int dst, offset;
9628
9629   if (timep == NULL) {
9630     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9631     return NULL;
9632   }
9633   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9634   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9635
9636   when = *timep;
9637 # ifdef RTL_USES_UTC
9638 # ifdef VMSISH_TIME
9639   if (VMSISH_TIME) when = _toutc(when);
9640 # endif
9641   /* CRTL localtime() wants UTC as input, does tz correction itself */
9642   return localtime(&when);
9643
9644 # else /* !RTL_USES_UTC */
9645   whenutc = when;
9646 # ifdef VMSISH_TIME
9647   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
9648   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
9649 # endif
9650   dst = -1;
9651 #ifndef RTL_USES_UTC
9652   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
9653       when = whenutc - offset;                   /* pseudolocal time*/
9654   }
9655 # endif
9656   /* CRTL localtime() wants local time as input, so does no tz correction */
9657   rsltmp = localtime(&when);
9658   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9659   return rsltmp;
9660 # endif
9661
9662 } /*  end of my_localtime() */
9663 /*}}}*/
9664
9665 /* Reset definitions for later calls */
9666 #define gmtime(t)    my_gmtime(t)
9667 #define localtime(t) my_localtime(t)
9668 #define time(t)      my_time(t)
9669
9670
9671 /* my_utime - update modification time of a file
9672  * calling sequence is identical to POSIX utime(), but under
9673  * VMS only the modification time is changed; ODS-2 does not
9674  * maintain access times.  Restrictions differ from the POSIX
9675  * definition in that the time can be changed as long as the
9676  * caller has permission to execute the necessary IO$_MODIFY $QIO;
9677  * no separate checks are made to insure that the caller is the
9678  * owner of the file or has special privs enabled.
9679  * Code here is based on Joe Meadows' FILE utility.
9680  */
9681
9682 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9683  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
9684  * in 100 ns intervals.
9685  */
9686 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9687
9688 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9689 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9690 {
9691   register int i;
9692   int sts;
9693   long int bintime[2], len = 2, lowbit, unixtime,
9694            secscale = 10000000; /* seconds --> 100 ns intervals */
9695   unsigned long int chan, iosb[2], retsts;
9696   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9697   struct FAB myfab = cc$rms_fab;
9698   struct NAM mynam = cc$rms_nam;
9699 #if defined (__DECC) && defined (__VAX)
9700   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9701    * at least through VMS V6.1, which causes a type-conversion warning.
9702    */
9703 #  pragma message save
9704 #  pragma message disable cvtdiftypes
9705 #endif
9706   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9707   struct fibdef myfib;
9708 #if defined (__DECC) && defined (__VAX)
9709   /* This should be right after the declaration of myatr, but due
9710    * to a bug in VAX DEC C, this takes effect a statement early.
9711    */
9712 #  pragma message restore
9713 #endif
9714   /* cast ok for read only parameter */
9715   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9716                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9717                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9718
9719   if (decc_efs_charset != 0) {
9720     struct utimbuf utc_utimes;
9721
9722     utc_utimes.actime = utimes->actime;
9723     utc_utimes.modtime = utimes->modtime;
9724 #   ifdef VMSISH_TIME
9725     /* If input was local; convert to UTC for sys svc */
9726     if (VMSISH_TIME) {
9727         utc_utimes.actime = _toutc(utimes->actime);
9728         utc_utimes.modtime = _toutc(utimes->modtime);
9729     }
9730 #   endif
9731     sts = utime(file, &utc_utimes);
9732     return sts;
9733   }
9734
9735   if (file == NULL || *file == '\0') {
9736     set_errno(ENOENT);
9737     set_vaxc_errno(LIB$_INVARG);
9738     return -1;
9739   }
9740
9741   /* Convert to VMS format ensuring that it will fit in 255 characters */
9742   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL)
9743         return -1;
9744
9745   if (utimes != NULL) {
9746     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
9747      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9748      * Since time_t is unsigned long int, and lib$emul takes a signed long int
9749      * as input, we force the sign bit to be clear by shifting unixtime right
9750      * one bit, then multiplying by an extra factor of 2 in lib$emul().
9751      */
9752     lowbit = (utimes->modtime & 1) ? secscale : 0;
9753     unixtime = (long int) utimes->modtime;
9754 #   ifdef VMSISH_TIME
9755     /* If input was UTC; convert to local for sys svc */
9756     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9757 #   endif
9758     unixtime >>= 1;  secscale <<= 1;
9759     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9760     if (!(retsts & 1)) {
9761       set_errno(EVMSERR);
9762       set_vaxc_errno(retsts);
9763       return -1;
9764     }
9765     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9766     if (!(retsts & 1)) {
9767       set_errno(EVMSERR);
9768       set_vaxc_errno(retsts);
9769       return -1;
9770     }
9771   }
9772   else {
9773     /* Just get the current time in VMS format directly */
9774     retsts = sys$gettim(bintime);
9775     if (!(retsts & 1)) {
9776       set_errno(EVMSERR);
9777       set_vaxc_errno(retsts);
9778       return -1;
9779     }
9780   }
9781
9782   myfab.fab$l_fna = vmsspec;
9783   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9784   myfab.fab$l_nam = &mynam;
9785   mynam.nam$l_esa = esa;
9786   mynam.nam$b_ess = (unsigned char) sizeof esa;
9787   mynam.nam$l_rsa = rsa;
9788   mynam.nam$b_rss = (unsigned char) sizeof rsa;
9789   if (decc_efs_case_preserve)
9790       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9791
9792   /* Look for the file to be affected, letting RMS parse the file
9793    * specification for us as well.  I have set errno using only
9794    * values documented in the utime() man page for VMS POSIX.
9795    */
9796   retsts = sys$parse(&myfab,0,0);
9797   if (!(retsts & 1)) {
9798     set_vaxc_errno(retsts);
9799     if      (retsts == RMS$_PRV) set_errno(EACCES);
9800     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9801     else                         set_errno(EVMSERR);
9802     return -1;
9803   }
9804   retsts = sys$search(&myfab,0,0);
9805   if (!(retsts & 1)) {
9806     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9807     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9808     set_vaxc_errno(retsts);
9809     if      (retsts == RMS$_PRV) set_errno(EACCES);
9810     else if (retsts == RMS$_FNF) set_errno(ENOENT);
9811     else                         set_errno(EVMSERR);
9812     return -1;
9813   }
9814
9815   devdsc.dsc$w_length = mynam.nam$b_dev;
9816   /* cast ok for read only parameter */
9817   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9818
9819   retsts = sys$assign(&devdsc,&chan,0,0);
9820   if (!(retsts & 1)) {
9821     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9822     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9823     set_vaxc_errno(retsts);
9824     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
9825     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
9826     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
9827     else                               set_errno(EVMSERR);
9828     return -1;
9829   }
9830
9831   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9832   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9833
9834   memset((void *) &myfib, 0, sizeof myfib);
9835 #if defined(__DECC) || defined(__DECCXX)
9836   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9837   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9838   /* This prevents the revision time of the file being reset to the current
9839    * time as a result of our IO$_MODIFY $QIO. */
9840   myfib.fib$l_acctl = FIB$M_NORECORD;
9841 #else
9842   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9843   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9844   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9845 #endif
9846   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9847   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9848   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9849   _ckvmssts(sys$dassgn(chan));
9850   if (retsts & 1) retsts = iosb[0];
9851   if (!(retsts & 1)) {
9852     set_vaxc_errno(retsts);
9853     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9854     else                      set_errno(EVMSERR);
9855     return -1;
9856   }
9857
9858   return 0;
9859 }  /* end of my_utime() */
9860 /*}}}*/
9861
9862 /*
9863  * flex_stat, flex_lstat, flex_fstat
9864  * basic stat, but gets it right when asked to stat
9865  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9866  */
9867
9868 #ifndef _USE_STD_STAT
9869 /* encode_dev packs a VMS device name string into an integer to allow
9870  * simple comparisons. This can be used, for example, to check whether two
9871  * files are located on the same device, by comparing their encoded device
9872  * names. Even a string comparison would not do, because stat() reuses the
9873  * device name buffer for each call; so without encode_dev, it would be
9874  * necessary to save the buffer and use strcmp (this would mean a number of
9875  * changes to the standard Perl code, to say nothing of what a Perl script
9876  * would have to do.
9877  *
9878  * The device lock id, if it exists, should be unique (unless perhaps compared
9879  * with lock ids transferred from other nodes). We have a lock id if the disk is
9880  * mounted cluster-wide, which is when we tend to get long (host-qualified)
9881  * device names. Thus we use the lock id in preference, and only if that isn't
9882  * available, do we try to pack the device name into an integer (flagged by
9883  * the sign bit (LOCKID_MASK) being set).
9884  *
9885  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9886  * name and its encoded form, but it seems very unlikely that we will find
9887  * two files on different disks that share the same encoded device names,
9888  * and even more remote that they will share the same file id (if the test
9889  * is to check for the same file).
9890  *
9891  * A better method might be to use sys$device_scan on the first call, and to
9892  * search for the device, returning an index into the cached array.
9893  * The number returned would be more intelligable.
9894  * This is probably not worth it, and anyway would take quite a bit longer
9895  * on the first call.
9896  */
9897 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
9898 static mydev_t encode_dev (pTHX_ const char *dev)
9899 {
9900   int i;
9901   unsigned long int f;
9902   mydev_t enc;
9903   char c;
9904   const char *q;
9905
9906   if (!dev || !dev[0]) return 0;
9907
9908 #if LOCKID_MASK
9909   {
9910     struct dsc$descriptor_s dev_desc;
9911     unsigned long int status, lockid, item = DVI$_LOCKID;
9912
9913     /* For cluster-mounted disks, the disk lock identifier is unique, so we
9914        can try that first. */
9915     dev_desc.dsc$w_length =  strlen (dev);
9916     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
9917     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
9918     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
9919     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9920     if (lockid) return (lockid & ~LOCKID_MASK);
9921   }
9922 #endif
9923
9924   /* Otherwise we try to encode the device name */
9925   enc = 0;
9926   f = 1;
9927   i = 0;
9928   for (q = dev + strlen(dev); q--; q >= dev) {
9929     if (*q == ':')
9930         break;
9931     if (isdigit (*q))
9932       c= (*q) - '0';
9933     else if (isalpha (toupper (*q)))
9934       c= toupper (*q) - 'A' + (char)10;
9935     else
9936       continue; /* Skip '$'s */
9937     i++;
9938     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
9939     if (i>1) f *= 36;
9940     enc += f * (unsigned long int) c;
9941   }
9942   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
9943
9944 }  /* end of encode_dev() */
9945 #endif
9946
9947 static int
9948 is_null_device(name)
9949     const char *name;
9950 {
9951   if (decc_bug_devnull != 0) {
9952     if (strncmp("/dev/null", name, 9) == 0)
9953       return 1;
9954   }
9955     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9956        The underscore prefix, controller letter, and unit number are
9957        independently optional; for our purposes, the colon punctuation
9958        is not.  The colon can be trailed by optional directory and/or
9959        filename, but two consecutive colons indicates a nodename rather
9960        than a device.  [pr]  */
9961   if (*name == '_') ++name;
9962   if (tolower(*name++) != 'n') return 0;
9963   if (tolower(*name++) != 'l') return 0;
9964   if (tolower(*name) == 'a') ++name;
9965   if (*name == '0') ++name;
9966   return (*name++ == ':') && (*name != ':');
9967 }
9968
9969 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
9970 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9971  * subset of the applicable information.
9972  */
9973 bool
9974 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
9975 {
9976   return cando_by_name(bit,effective, statbufp->st_devnam);
9977 }  /* end of cando() */
9978 /*}}}*/
9979
9980
9981 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
9982 I32
9983 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
9984 {
9985   static char usrname[L_cuserid];
9986   static struct dsc$descriptor_s usrdsc =
9987          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
9988   char vmsname[NAM$C_MAXRSS+1];
9989   char *fileified;
9990   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
9991   unsigned short int retlen, trnlnm_iter_count;
9992   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9993   union prvdef curprv;
9994   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9995          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
9996   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9997          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9998          {0,0,0,0}};
9999   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10000          {0,0,0,0}};
10001   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10002
10003   if (!fname || !*fname) return FALSE;
10004   /* Make sure we expand logical names, since sys$check_access doesn't */
10005   fileified = PerlMem_malloc(VMS_MAXRSS);
10006   if (!strpbrk(fname,"/]>:")) {
10007     strcpy(fileified,fname);
10008     trnlnm_iter_count = 0;
10009     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10010         trnlnm_iter_count++;
10011         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10012     }
10013     fname = fileified;
10014   }
10015   if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS)) {
10016     PerlMem_free(fileified);
10017     return FALSE;
10018   }
10019   retlen = namdsc.dsc$w_length = strlen(vmsname);
10020   namdsc.dsc$a_pointer = vmsname;
10021   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10022       vmsname[retlen-1] == ':') {
10023     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
10024     namdsc.dsc$w_length = strlen(fileified);
10025     namdsc.dsc$a_pointer = fileified;
10026   }
10027
10028   switch (bit) {
10029     case S_IXUSR: case S_IXGRP: case S_IXOTH:
10030       access = ARM$M_EXECUTE; break;
10031     case S_IRUSR: case S_IRGRP: case S_IROTH:
10032       access = ARM$M_READ; break;
10033     case S_IWUSR: case S_IWGRP: case S_IWOTH:
10034       access = ARM$M_WRITE; break;
10035     case S_IDUSR: case S_IDGRP: case S_IDOTH:
10036       access = ARM$M_DELETE; break;
10037     default:
10038       PerlMem_free(fileified);
10039       return FALSE;
10040   }
10041
10042   /* Before we call $check_access, create a user profile with the current
10043    * process privs since otherwise it just uses the default privs from the
10044    * UAF and might give false positives or negatives.  This only works on
10045    * VMS versions v6.0 and later since that's when sys$create_user_profile
10046    * became available.
10047    */
10048
10049   /* get current process privs and username */
10050   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10051   _ckvmssts(iosb[0]);
10052
10053 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10054
10055   /* find out the space required for the profile */
10056   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10057                                     &usrprodsc.dsc$w_length,0));
10058
10059   /* allocate space for the profile and get it filled in */
10060   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10061   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10062   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10063                                     &usrprodsc.dsc$w_length,0));
10064
10065   /* use the profile to check access to the file; free profile & analyze results */
10066   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10067   PerlMem_free(usrprodsc.dsc$a_pointer);
10068   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10069
10070 #else
10071
10072   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10073
10074 #endif
10075
10076   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
10077       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10078       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10079     set_vaxc_errno(retsts);
10080     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10081     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10082     else set_errno(ENOENT);
10083     PerlMem_free(fileified);
10084     return FALSE;
10085   }
10086   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10087     PerlMem_free(fileified);
10088     return TRUE;
10089   }
10090   _ckvmssts(retsts);
10091
10092   PerlMem_free(fileified);
10093   return FALSE;  /* Should never get here */
10094
10095 }  /* end of cando_by_name() */
10096 /*}}}*/
10097
10098
10099 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10100 int
10101 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10102 {
10103   if (!fstat(fd,(stat_t *) statbufp)) {
10104     char *cptr;
10105     char *vms_filename;
10106     vms_filename = PerlMem_malloc(VMS_MAXRSS);
10107     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
10108
10109     /* Save name for cando by name in VMS format */
10110     cptr = getname(fd, vms_filename, 1);
10111
10112     /* This should not happen, but just in case */
10113     if (cptr == NULL) {
10114         statbufp->st_devnam[0] = 0;
10115     }
10116     else {
10117         /* Make sure that the saved name fits in 255 characters */
10118         cptr = do_rmsexpand
10119                        (vms_filename,
10120                         statbufp->st_devnam,
10121                         0,
10122                         NULL,
10123                         PERL_RMSEXPAND_M_VMS);
10124         if (cptr == NULL)
10125             statbufp->st_devnam[0] = 0;
10126     }
10127     PerlMem_free(vms_filename);
10128
10129     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10130 #ifndef _USE_STD_STAT
10131     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
10132 #endif
10133
10134 #   ifdef RTL_USES_UTC
10135 #   ifdef VMSISH_TIME
10136     if (VMSISH_TIME) {
10137       statbufp->st_mtime = _toloc(statbufp->st_mtime);
10138       statbufp->st_atime = _toloc(statbufp->st_atime);
10139       statbufp->st_ctime = _toloc(statbufp->st_ctime);
10140     }
10141 #   endif
10142 #   else
10143 #   ifdef VMSISH_TIME
10144     if (!VMSISH_TIME) { /* Return UTC instead of local time */
10145 #   else
10146     if (1) {
10147 #   endif
10148       statbufp->st_mtime = _toutc(statbufp->st_mtime);
10149       statbufp->st_atime = _toutc(statbufp->st_atime);
10150       statbufp->st_ctime = _toutc(statbufp->st_ctime);
10151     }
10152 #endif
10153     return 0;
10154   }
10155   return -1;
10156
10157 }  /* end of flex_fstat() */
10158 /*}}}*/
10159
10160 #if !defined(__VAX) && __CRTL_VER >= 80200000
10161 #ifdef lstat
10162 #undef lstat
10163 #endif
10164 #else
10165 #ifdef lstat
10166 #undef lstat
10167 #endif
10168 #define lstat(_x, _y) stat(_x, _y)
10169 #endif
10170
10171 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
10172
10173 static int
10174 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10175 {
10176     char fileified[VMS_MAXRSS];
10177     char temp_fspec[VMS_MAXRSS];
10178     char *save_spec;
10179     int retval = -1;
10180     int saved_errno, saved_vaxc_errno;
10181
10182     if (!fspec) return retval;
10183     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10184     strcpy(temp_fspec, fspec);
10185
10186     if (decc_bug_devnull != 0) {
10187       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10188         memset(statbufp,0,sizeof *statbufp);
10189         statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
10190         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10191         statbufp->st_uid = 0x00010001;
10192         statbufp->st_gid = 0x0001;
10193         time((time_t *)&statbufp->st_mtime);
10194         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10195         return 0;
10196       }
10197     }
10198
10199     /* Try for a directory name first.  If fspec contains a filename without
10200      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10201      * and sea:[wine.dark]water. exist, we prefer the directory here.
10202      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10203      * not sea:[wine.dark]., if the latter exists.  If the intended target is
10204      * the file with null type, specify this by calling flex_stat() with
10205      * a '.' at the end of fspec.
10206      *
10207      * If we are in Posix filespec mode, accept the filename as is.
10208      */
10209 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10210   if (decc_posix_compliant_pathnames == 0) {
10211 #endif
10212     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
10213       if (lstat_flag == 0)
10214         retval = stat(fileified,(stat_t *) statbufp);
10215       else
10216         retval = lstat(fileified,(stat_t *) statbufp);
10217       save_spec = fileified;
10218     }
10219     if (retval) {
10220       if (lstat_flag == 0)
10221         retval = stat(temp_fspec,(stat_t *) statbufp);
10222       else
10223         retval = lstat(temp_fspec,(stat_t *) statbufp);
10224       save_spec = temp_fspec;
10225     }
10226 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10227   } else {
10228     if (lstat_flag == 0)
10229       retval = stat(temp_fspec,(stat_t *) statbufp);
10230     else
10231       retval = lstat(temp_fspec,(stat_t *) statbufp);
10232       save_spec = temp_fspec;
10233   }
10234 #endif
10235     if (!retval) {
10236     char * cptr;
10237       cptr = do_rmsexpand
10238             (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS);
10239       if (cptr == NULL)
10240         statbufp->st_devnam[0] = 0;
10241
10242       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10243 #ifndef _USE_STD_STAT
10244       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
10245 #endif
10246 #     ifdef RTL_USES_UTC
10247 #     ifdef VMSISH_TIME
10248       if (VMSISH_TIME) {
10249         statbufp->st_mtime = _toloc(statbufp->st_mtime);
10250         statbufp->st_atime = _toloc(statbufp->st_atime);
10251         statbufp->st_ctime = _toloc(statbufp->st_ctime);
10252       }
10253 #     endif
10254 #     else
10255 #     ifdef VMSISH_TIME
10256       if (!VMSISH_TIME) { /* Return UTC instead of local time */
10257 #     else
10258       if (1) {
10259 #     endif
10260         statbufp->st_mtime = _toutc(statbufp->st_mtime);
10261         statbufp->st_atime = _toutc(statbufp->st_atime);
10262         statbufp->st_ctime = _toutc(statbufp->st_ctime);
10263       }
10264 #     endif
10265     }
10266     /* If we were successful, leave errno where we found it */
10267     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10268     return retval;
10269
10270 }  /* end of flex_stat_int() */
10271
10272
10273 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10274 int
10275 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10276 {
10277    return flex_stat_int(fspec, statbufp, 0);
10278 }
10279 /*}}}*/
10280
10281 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10282 int
10283 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10284 {
10285    return flex_stat_int(fspec, statbufp, 1);
10286 }
10287 /*}}}*/
10288
10289
10290 /*{{{char *my_getlogin()*/
10291 /* VMS cuserid == Unix getlogin, except calling sequence */
10292 char *
10293 my_getlogin(void)
10294 {
10295     static char user[L_cuserid];
10296     return cuserid(user);
10297 }
10298 /*}}}*/
10299
10300
10301 /*  rmscopy - copy a file using VMS RMS routines
10302  *
10303  *  Copies contents and attributes of spec_in to spec_out, except owner
10304  *  and protection information.  Name and type of spec_in are used as
10305  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
10306  *  should try to propagate timestamps from the input file to the output file.
10307  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
10308  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
10309  *  propagated to the output file at creation iff the output file specification
10310  *  did not contain an explicit name or type, and the revision date is always
10311  *  updated at the end of the copy operation.  If it is greater than 0, then
10312  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
10313  *  other than the revision date should be propagated, and bit 1 indicates
10314  *  that the revision date should be propagated.
10315  *
10316  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
10317  *
10318  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
10319  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
10320  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
10321  * as part of the Perl standard distribution under the terms of the
10322  * GNU General Public License or the Perl Artistic License.  Copies
10323  * of each may be found in the Perl standard distribution.
10324  */ /* FIXME */
10325 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
10326 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
10327 int
10328 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10329 {
10330     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
10331          rsa[NAM$C_MAXRSS], ubf[32256];
10332     unsigned long int i, sts, sts2;
10333     struct FAB fab_in, fab_out;
10334     struct RAB rab_in, rab_out;
10335     struct NAM nam;
10336     struct XABDAT xabdat;
10337     struct XABFHC xabfhc;
10338     struct XABRDT xabrdt;
10339     struct XABSUM xabsum;
10340
10341     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
10342         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10343       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10344       return 0;
10345     }
10346
10347     fab_in = cc$rms_fab;
10348     fab_in.fab$l_fna = vmsin;
10349     fab_in.fab$b_fns = strlen(vmsin);
10350     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10351     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10352     fab_in.fab$l_fop = FAB$M_SQO;
10353     fab_in.fab$l_nam =  &nam;
10354     fab_in.fab$l_xab = (void *) &xabdat;
10355
10356     nam = cc$rms_nam;
10357     nam.nam$l_rsa = rsa;
10358     nam.nam$b_rss = sizeof(rsa);
10359     nam.nam$l_esa = esa;
10360     nam.nam$b_ess = sizeof (esa);
10361     nam.nam$b_esl = nam.nam$b_rsl = 0;
10362 #ifdef NAM$M_NO_SHORT_UPCASE
10363     if (decc_efs_case_preserve)
10364         nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10365 #endif
10366
10367     xabdat = cc$rms_xabdat;        /* To get creation date */
10368     xabdat.xab$l_nxt = (void *) &xabfhc;
10369
10370     xabfhc = cc$rms_xabfhc;        /* To get record length */
10371     xabfhc.xab$l_nxt = (void *) &xabsum;
10372
10373     xabsum = cc$rms_xabsum;        /* To get key and area information */
10374
10375     if (!((sts = sys$open(&fab_in)) & 1)) {
10376       set_vaxc_errno(sts);
10377       switch (sts) {
10378         case RMS$_FNF: case RMS$_DNF:
10379           set_errno(ENOENT); break;
10380         case RMS$_DIR:
10381           set_errno(ENOTDIR); break;
10382         case RMS$_DEV:
10383           set_errno(ENODEV); break;
10384         case RMS$_SYN:
10385           set_errno(EINVAL); break;
10386         case RMS$_PRV:
10387           set_errno(EACCES); break;
10388         default:
10389           set_errno(EVMSERR);
10390       }
10391       return 0;
10392     }
10393
10394     fab_out = fab_in;
10395     fab_out.fab$w_ifi = 0;
10396     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10397     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10398     fab_out.fab$l_fop = FAB$M_SQO;
10399     fab_out.fab$l_fna = vmsout;
10400     fab_out.fab$b_fns = strlen(vmsout);
10401     fab_out.fab$l_dna = nam.nam$l_name;
10402     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
10403
10404     if (preserve_dates == 0) {  /* Act like DCL COPY */
10405       nam.nam$b_nop |= NAM$M_SYNCHK;
10406       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10407       if (!((sts = sys$parse(&fab_out)) & 1)) {
10408         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10409         set_vaxc_errno(sts);
10410         return 0;
10411       }
10412       fab_out.fab$l_xab = (void *) &xabdat;
10413       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10414     }
10415     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
10416     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10417       preserve_dates =0;      /* bitmask from this point forward   */
10418
10419     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10420     if (!((sts = sys$create(&fab_out)) & 1)) {
10421       set_vaxc_errno(sts);
10422       switch (sts) {
10423         case RMS$_DNF:
10424           set_errno(ENOENT); break;
10425         case RMS$_DIR:
10426           set_errno(ENOTDIR); break;
10427         case RMS$_DEV:
10428           set_errno(ENODEV); break;
10429         case RMS$_SYN:
10430           set_errno(EINVAL); break;
10431         case RMS$_PRV:
10432           set_errno(EACCES); break;
10433         default:
10434           set_errno(EVMSERR);
10435       }
10436       return 0;
10437     }
10438     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10439     if (preserve_dates & 2) {
10440       /* sys$close() will process xabrdt, not xabdat */
10441       xabrdt = cc$rms_xabrdt;
10442 #ifndef __GNUC__
10443       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10444 #else
10445       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10446        * is unsigned long[2], while DECC & VAXC use a struct */
10447       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10448 #endif
10449       fab_out.fab$l_xab = (void *) &xabrdt;
10450     }
10451
10452     rab_in = cc$rms_rab;
10453     rab_in.rab$l_fab = &fab_in;
10454     rab_in.rab$l_rop = RAB$M_BIO;
10455     rab_in.rab$l_ubf = ubf;
10456     rab_in.rab$w_usz = sizeof ubf;
10457     if (!((sts = sys$connect(&rab_in)) & 1)) {
10458       sys$close(&fab_in); sys$close(&fab_out);
10459       set_errno(EVMSERR); set_vaxc_errno(sts);
10460       return 0;
10461     }
10462
10463     rab_out = cc$rms_rab;
10464     rab_out.rab$l_fab = &fab_out;
10465     rab_out.rab$l_rbf = ubf;
10466     if (!((sts = sys$connect(&rab_out)) & 1)) {
10467       sys$close(&fab_in); sys$close(&fab_out);
10468       set_errno(EVMSERR); set_vaxc_errno(sts);
10469       return 0;
10470     }
10471
10472     while ((sts = sys$read(&rab_in))) {  /* always true  */
10473       if (sts == RMS$_EOF) break;
10474       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10475       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10476         sys$close(&fab_in); sys$close(&fab_out);
10477         set_errno(EVMSERR); set_vaxc_errno(sts);
10478         return 0;
10479       }
10480     }
10481
10482     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10483     sys$close(&fab_in);  sys$close(&fab_out);
10484     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10485     if (!(sts & 1)) {
10486       set_errno(EVMSERR); set_vaxc_errno(sts);
10487       return 0;
10488     }
10489
10490     return 1;
10491
10492 }  /* end of rmscopy() */
10493 #else
10494 /* ODS-5 support version */
10495 int
10496 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10497 {
10498     char *vmsin, * vmsout, *esa, *esa_out,
10499          *rsa, *ubf;
10500     unsigned long int i, sts, sts2;
10501     struct FAB fab_in, fab_out;
10502     struct RAB rab_in, rab_out;
10503     struct NAML nam;
10504     struct NAML nam_out;
10505     struct XABDAT xabdat;
10506     struct XABFHC xabfhc;
10507     struct XABRDT xabrdt;
10508     struct XABSUM xabsum;
10509
10510     vmsin = PerlMem_malloc(VMS_MAXRSS);
10511     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
10512     vmsout = PerlMem_malloc(VMS_MAXRSS);
10513     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
10514     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
10515         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10516       PerlMem_free(vmsin);
10517       PerlMem_free(vmsout);
10518       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10519       return 0;
10520     }
10521
10522     esa = PerlMem_malloc(VMS_MAXRSS);
10523     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
10524     nam = cc$rms_naml;
10525     fab_in = cc$rms_fab;
10526     fab_in.fab$l_fna = (char *) -1;
10527     fab_in.fab$b_fns = 0;
10528     nam.naml$l_long_filename = vmsin;
10529     nam.naml$l_long_filename_size = strlen(vmsin);
10530     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10531     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10532     fab_in.fab$l_fop = FAB$M_SQO;
10533     fab_in.fab$l_naml =  &nam;
10534     fab_in.fab$l_xab = (void *) &xabdat;
10535
10536     rsa = PerlMem_malloc(VMS_MAXRSS);
10537     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
10538     nam.naml$l_rsa = NULL;
10539     nam.naml$b_rss = 0;
10540     nam.naml$l_long_result = rsa;
10541     nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10542     nam.naml$l_esa = NULL;
10543     nam.naml$b_ess = 0;
10544     nam.naml$l_long_expand = esa;
10545     nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10546     nam.naml$b_esl = nam.naml$b_rsl = 0;
10547     nam.naml$l_long_expand_size = 0;
10548     nam.naml$l_long_result_size = 0;
10549 #ifdef NAM$M_NO_SHORT_UPCASE
10550     if (decc_efs_case_preserve)
10551         nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10552 #endif
10553
10554     xabdat = cc$rms_xabdat;        /* To get creation date */
10555     xabdat.xab$l_nxt = (void *) &xabfhc;
10556
10557     xabfhc = cc$rms_xabfhc;        /* To get record length */
10558     xabfhc.xab$l_nxt = (void *) &xabsum;
10559
10560     xabsum = cc$rms_xabsum;        /* To get key and area information */
10561
10562     if (!((sts = sys$open(&fab_in)) & 1)) {
10563       PerlMem_free(vmsin);
10564       PerlMem_free(vmsout);
10565       PerlMem_free(esa);
10566       PerlMem_free(rsa);
10567       set_vaxc_errno(sts);
10568       switch (sts) {
10569         case RMS$_FNF: case RMS$_DNF:
10570           set_errno(ENOENT); break;
10571         case RMS$_DIR:
10572           set_errno(ENOTDIR); break;
10573         case RMS$_DEV:
10574           set_errno(ENODEV); break;
10575         case RMS$_SYN:
10576           set_errno(EINVAL); break;
10577         case RMS$_PRV:
10578           set_errno(EACCES); break;
10579         default:
10580           set_errno(EVMSERR);
10581       }
10582       return 0;
10583     }
10584
10585     nam_out = nam;
10586     fab_out = fab_in;
10587     fab_out.fab$w_ifi = 0;
10588     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10589     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10590     fab_out.fab$l_fop = FAB$M_SQO;
10591     fab_out.fab$l_naml = &nam_out;
10592     fab_out.fab$l_fna = (char *) -1;
10593     fab_out.fab$b_fns = 0;
10594     nam_out.naml$l_long_filename = vmsout;
10595     nam_out.naml$l_long_filename_size = strlen(vmsout);
10596     fab_out.fab$l_dna = (char *) -1;
10597     fab_out.fab$b_dns = 0;
10598     nam_out.naml$l_long_defname = nam.naml$l_long_name;
10599     nam_out.naml$l_long_defname_size =
10600         nam.naml$l_long_name ?
10601            nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10602
10603     esa_out = PerlMem_malloc(VMS_MAXRSS);
10604     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
10605     nam_out.naml$l_rsa = NULL;
10606     nam_out.naml$b_rss = 0;
10607     nam_out.naml$l_long_result = NULL;
10608     nam_out.naml$l_long_result_alloc = 0;
10609     nam_out.naml$l_esa = NULL;
10610     nam_out.naml$b_ess = 0;
10611     nam_out.naml$l_long_expand = esa_out;
10612     nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10613
10614     if (preserve_dates == 0) {  /* Act like DCL COPY */
10615       nam_out.naml$b_nop |= NAM$M_SYNCHK;
10616       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10617       if (!((sts = sys$parse(&fab_out)) & 1)) {
10618         PerlMem_free(vmsin);
10619         PerlMem_free(vmsout);
10620         PerlMem_free(esa);
10621         PerlMem_free(rsa);
10622         PerlMem_free(esa_out);
10623         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10624         set_vaxc_errno(sts);
10625         return 0;
10626       }
10627       fab_out.fab$l_xab = (void *) &xabdat;
10628       if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10629     }
10630     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10631       preserve_dates =0;      /* bitmask from this point forward   */
10632
10633     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10634     if (!((sts = sys$create(&fab_out)) & 1)) {
10635       PerlMem_free(vmsin);
10636       PerlMem_free(vmsout);
10637       PerlMem_free(esa);
10638       PerlMem_free(rsa);
10639       PerlMem_free(esa_out);
10640       set_vaxc_errno(sts);
10641       switch (sts) {
10642         case RMS$_DNF:
10643           set_errno(ENOENT); break;
10644         case RMS$_DIR:
10645           set_errno(ENOTDIR); break;
10646         case RMS$_DEV:
10647           set_errno(ENODEV); break;
10648         case RMS$_SYN:
10649           set_errno(EINVAL); break;
10650         case RMS$_PRV:
10651           set_errno(EACCES); break;
10652         default:
10653           set_errno(EVMSERR);
10654       }
10655       return 0;
10656     }
10657     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10658     if (preserve_dates & 2) {
10659       /* sys$close() will process xabrdt, not xabdat */
10660       xabrdt = cc$rms_xabrdt;
10661 #ifndef __GNUC__
10662       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10663 #else
10664       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10665        * is unsigned long[2], while DECC & VAXC use a struct */
10666       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10667 #endif
10668       fab_out.fab$l_xab = (void *) &xabrdt;
10669     }
10670
10671     ubf = PerlMem_malloc(32256);
10672     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
10673     rab_in = cc$rms_rab;
10674     rab_in.rab$l_fab = &fab_in;
10675     rab_in.rab$l_rop = RAB$M_BIO;
10676     rab_in.rab$l_ubf = ubf;
10677     rab_in.rab$w_usz = 32256;
10678     if (!((sts = sys$connect(&rab_in)) & 1)) {
10679       sys$close(&fab_in); sys$close(&fab_out);
10680       PerlMem_free(vmsin);
10681       PerlMem_free(vmsout);
10682       PerlMem_free(esa);
10683       PerlMem_free(ubf);
10684       PerlMem_free(rsa);
10685       PerlMem_free(esa_out);
10686       set_errno(EVMSERR); set_vaxc_errno(sts);
10687       return 0;
10688     }
10689
10690     rab_out = cc$rms_rab;
10691     rab_out.rab$l_fab = &fab_out;
10692     rab_out.rab$l_rbf = ubf;
10693     if (!((sts = sys$connect(&rab_out)) & 1)) {
10694       sys$close(&fab_in); sys$close(&fab_out);
10695       PerlMem_free(vmsin);
10696       PerlMem_free(vmsout);
10697       PerlMem_free(esa);
10698       PerlMem_free(ubf);
10699       PerlMem_free(rsa);
10700       PerlMem_free(esa_out);
10701       set_errno(EVMSERR); set_vaxc_errno(sts);
10702       return 0;
10703     }
10704
10705     while ((sts = sys$read(&rab_in))) {  /* always true  */
10706       if (sts == RMS$_EOF) break;
10707       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10708       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10709         sys$close(&fab_in); sys$close(&fab_out);
10710         PerlMem_free(vmsin);
10711         PerlMem_free(vmsout);
10712         PerlMem_free(esa);
10713         PerlMem_free(ubf);
10714         PerlMem_free(rsa);
10715         PerlMem_free(esa_out);
10716         set_errno(EVMSERR); set_vaxc_errno(sts);
10717         return 0;
10718       }
10719     }
10720
10721
10722     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10723     sys$close(&fab_in);  sys$close(&fab_out);
10724     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10725     if (!(sts & 1)) {
10726       PerlMem_free(vmsin);
10727       PerlMem_free(vmsout);
10728       PerlMem_free(esa);
10729       PerlMem_free(ubf);
10730       PerlMem_free(rsa);
10731       PerlMem_free(esa_out);
10732       set_errno(EVMSERR); set_vaxc_errno(sts);
10733       return 0;
10734     }
10735
10736     PerlMem_free(vmsin);
10737     PerlMem_free(vmsout);
10738     PerlMem_free(esa);
10739     PerlMem_free(ubf);
10740     PerlMem_free(rsa);
10741     PerlMem_free(esa_out);
10742     return 1;
10743
10744 }  /* end of rmscopy() */
10745 #endif
10746 /*}}}*/
10747
10748
10749 /***  The following glue provides 'hooks' to make some of the routines
10750  * from this file available from Perl.  These routines are sufficiently
10751  * basic, and are required sufficiently early in the build process,
10752  * that's it's nice to have them available to miniperl as well as the
10753  * full Perl, so they're set up here instead of in an extension.  The
10754  * Perl code which handles importation of these names into a given
10755  * package lives in [.VMS]Filespec.pm in @INC.
10756  */
10757
10758 void
10759 rmsexpand_fromperl(pTHX_ CV *cv)
10760 {
10761   dXSARGS;
10762   char *fspec, *defspec = NULL, *rslt;
10763   STRLEN n_a;
10764
10765   if (!items || items > 2)
10766     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10767   fspec = SvPV(ST(0),n_a);
10768   if (!fspec || !*fspec) XSRETURN_UNDEF;
10769   if (items == 2) defspec = SvPV(ST(1),n_a);
10770
10771   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10772   ST(0) = sv_newmortal();
10773   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10774   XSRETURN(1);
10775 }
10776
10777 void
10778 vmsify_fromperl(pTHX_ CV *cv)
10779 {
10780   dXSARGS;
10781   char *vmsified;
10782   STRLEN n_a;
10783
10784   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10785   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10786   ST(0) = sv_newmortal();
10787   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10788   XSRETURN(1);
10789 }
10790
10791 void
10792 unixify_fromperl(pTHX_ CV *cv)
10793 {
10794   dXSARGS;
10795   char *unixified;
10796   STRLEN n_a;
10797
10798   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10799   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10800   ST(0) = sv_newmortal();
10801   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10802   XSRETURN(1);
10803 }
10804
10805 void
10806 fileify_fromperl(pTHX_ CV *cv)
10807 {
10808   dXSARGS;
10809   char *fileified;
10810   STRLEN n_a;
10811
10812   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10813   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10814   ST(0) = sv_newmortal();
10815   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10816   XSRETURN(1);
10817 }
10818
10819 void
10820 pathify_fromperl(pTHX_ CV *cv)
10821 {
10822   dXSARGS;
10823   char *pathified;
10824   STRLEN n_a;
10825
10826   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10827   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10828   ST(0) = sv_newmortal();
10829   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10830   XSRETURN(1);
10831 }
10832
10833 void
10834 vmspath_fromperl(pTHX_ CV *cv)
10835 {
10836   dXSARGS;
10837   char *vmspath;
10838   STRLEN n_a;
10839
10840   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10841   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10842   ST(0) = sv_newmortal();
10843   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10844   XSRETURN(1);
10845 }
10846
10847 void
10848 unixpath_fromperl(pTHX_ CV *cv)
10849 {
10850   dXSARGS;
10851   char *unixpath;
10852   STRLEN n_a;
10853
10854   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10855   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10856   ST(0) = sv_newmortal();
10857   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10858   XSRETURN(1);
10859 }
10860
10861 void
10862 candelete_fromperl(pTHX_ CV *cv)
10863 {
10864   dXSARGS;
10865   char *fspec, *fsp;
10866   SV *mysv;
10867   IO *io;
10868   STRLEN n_a;
10869
10870   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10871
10872   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10873   Newx(fspec, VMS_MAXRSS, char);
10874   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
10875   if (SvTYPE(mysv) == SVt_PVGV) {
10876     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10877       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10878       ST(0) = &PL_sv_no;
10879       Safefree(fspec);
10880       XSRETURN(1);
10881     }
10882     fsp = fspec;
10883   }
10884   else {
10885     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10886       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10887       ST(0) = &PL_sv_no;
10888       Safefree(fspec);
10889       XSRETURN(1);
10890     }
10891   }
10892
10893   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10894   Safefree(fspec);
10895   XSRETURN(1);
10896 }
10897
10898 void
10899 rmscopy_fromperl(pTHX_ CV *cv)
10900 {
10901   dXSARGS;
10902   char *inspec, *outspec, *inp, *outp;
10903   int date_flag;
10904   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10905                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10906   unsigned long int sts;
10907   SV *mysv;
10908   IO *io;
10909   STRLEN n_a;
10910
10911   if (items < 2 || items > 3)
10912     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10913
10914   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10915   Newx(inspec, VMS_MAXRSS, char);
10916   if (SvTYPE(mysv) == SVt_PVGV) {
10917     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10918       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10919       ST(0) = &PL_sv_no;
10920       Safefree(inspec);
10921       XSRETURN(1);
10922     }
10923     inp = inspec;
10924   }
10925   else {
10926     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10927       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10928       ST(0) = &PL_sv_no;
10929       Safefree(inspec);
10930       XSRETURN(1);
10931     }
10932   }
10933   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
10934   Newx(outspec, VMS_MAXRSS, char);
10935   if (SvTYPE(mysv) == SVt_PVGV) {
10936     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
10937       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10938       ST(0) = &PL_sv_no;
10939       Safefree(inspec);
10940       Safefree(outspec);
10941       XSRETURN(1);
10942     }
10943     outp = outspec;
10944   }
10945   else {
10946     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
10947       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10948       ST(0) = &PL_sv_no;
10949       Safefree(inspec);
10950       Safefree(outspec);
10951       XSRETURN(1);
10952     }
10953   }
10954   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
10955
10956   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
10957   Safefree(inspec);
10958   Safefree(outspec);
10959   XSRETURN(1);
10960 }
10961
10962 /* The mod2fname is limited to shorter filenames by design, so it should
10963  * not be modified to support longer EFS pathnames
10964  */
10965 void
10966 mod2fname(pTHX_ CV *cv)
10967 {
10968   dXSARGS;
10969   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10970        workbuff[NAM$C_MAXRSS*1 + 1];
10971   int total_namelen = 3, counter, num_entries;
10972   /* ODS-5 ups this, but we want to be consistent, so... */
10973   int max_name_len = 39;
10974   AV *in_array = (AV *)SvRV(ST(0));
10975
10976   num_entries = av_len(in_array);
10977
10978   /* All the names start with PL_. */
10979   strcpy(ultimate_name, "PL_");
10980
10981   /* Clean up our working buffer */
10982   Zero(work_name, sizeof(work_name), char);
10983
10984   /* Run through the entries and build up a working name */
10985   for(counter = 0; counter <= num_entries; counter++) {
10986     /* If it's not the first name then tack on a __ */
10987     if (counter) {
10988       strcat(work_name, "__");
10989     }
10990     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10991                            PL_na));
10992   }
10993
10994   /* Check to see if we actually have to bother...*/
10995   if (strlen(work_name) + 3 <= max_name_len) {
10996     strcat(ultimate_name, work_name);
10997   } else {
10998     /* It's too darned big, so we need to go strip. We use the same */
10999     /* algorithm as xsubpp does. First, strip out doubled __ */
11000     char *source, *dest, last;
11001     dest = workbuff;
11002     last = 0;
11003     for (source = work_name; *source; source++) {
11004       if (last == *source && last == '_') {
11005         continue;
11006       }
11007       *dest++ = *source;
11008       last = *source;
11009     }
11010     /* Go put it back */
11011     strcpy(work_name, workbuff);
11012     /* Is it still too big? */
11013     if (strlen(work_name) + 3 > max_name_len) {
11014       /* Strip duplicate letters */
11015       last = 0;
11016       dest = workbuff;
11017       for (source = work_name; *source; source++) {
11018         if (last == toupper(*source)) {
11019         continue;
11020         }
11021         *dest++ = *source;
11022         last = toupper(*source);
11023       }
11024       strcpy(work_name, workbuff);
11025     }
11026
11027     /* Is it *still* too big? */
11028     if (strlen(work_name) + 3 > max_name_len) {
11029       /* Too bad, we truncate */
11030       work_name[max_name_len - 2] = 0;
11031     }
11032     strcat(ultimate_name, work_name);
11033   }
11034
11035   /* Okay, return it */
11036   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11037   XSRETURN(1);
11038 }
11039
11040 void
11041 hushexit_fromperl(pTHX_ CV *cv)
11042 {
11043     dXSARGS;
11044
11045     if (items > 0) {
11046         VMSISH_HUSHED = SvTRUE(ST(0));
11047     }
11048     ST(0) = boolSV(VMSISH_HUSHED);
11049     XSRETURN(1);
11050 }
11051
11052
11053 PerlIO *
11054 Perl_vms_start_glob
11055    (pTHX_ SV *tmpglob,
11056     IO *io)
11057 {
11058     PerlIO *fp;
11059     struct vs_str_st *rslt;
11060     char *vmsspec;
11061     char *rstr;
11062     char *begin, *cp;
11063     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11064     PerlIO *tmpfp;
11065     STRLEN i;
11066     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11067     struct dsc$descriptor_vs rsdsc;
11068     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11069     unsigned long hasver = 0, isunix = 0;
11070     unsigned long int lff_flags = 0;
11071     int rms_sts;
11072
11073 #ifdef VMS_LONGNAME_SUPPORT
11074     lff_flags = LIB$M_FIL_LONG_NAMES;
11075 #endif
11076     /* The Newx macro will not allow me to assign a smaller array
11077      * to the rslt pointer, so we will assign it to the begin char pointer
11078      * and then copy the value into the rslt pointer.
11079      */
11080     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11081     rslt = (struct vs_str_st *)begin;
11082     rslt->length = 0;
11083     rstr = &rslt->str[0];
11084     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11085     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11086     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11087     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11088
11089     Newx(vmsspec, VMS_MAXRSS, char);
11090
11091         /* We could find out if there's an explicit dev/dir or version
11092            by peeking into lib$find_file's internal context at
11093            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11094            but that's unsupported, so I don't want to do it now and
11095            have it bite someone in the future. */
11096         /* Fix-me: vms_split_path() is the only way to do this, the
11097            existing method will fail with many legal EFS or UNIX specifications
11098          */
11099
11100     cp = SvPV(tmpglob,i);
11101
11102     for (; i; i--) {
11103         if (cp[i] == ';') hasver = 1;
11104         if (cp[i] == '.') {
11105             if (sts) hasver = 1;
11106             else sts = 1;
11107         }
11108         if (cp[i] == '/') {
11109             hasdir = isunix = 1;
11110             break;
11111         }
11112         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11113             hasdir = 1;
11114             break;
11115         }
11116     }
11117     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11118         Stat_t st;
11119         int stat_sts;
11120         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11121         if (!stat_sts && S_ISDIR(st.st_mode)) {
11122             wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec);
11123             ok = (wilddsc.dsc$a_pointer != NULL);
11124         }
11125         else {
11126             wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec);
11127             ok = (wilddsc.dsc$a_pointer != NULL);
11128         }
11129         if (ok)
11130             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11131
11132         /* If not extended character set, replace ? with % */
11133         /* With extended character set, ? is a wildcard single character */
11134         if (!decc_efs_case_preserve) {
11135             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11136                 if (*cp == '?') *cp = '%';
11137         }
11138         sts = SS$_NORMAL;
11139         while (ok && $VMS_STATUS_SUCCESS(sts)) {
11140          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11141          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11142
11143             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11144                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
11145             if (!$VMS_STATUS_SUCCESS(sts))
11146                 break;
11147
11148             /* with varying string, 1st word of buffer contains result length */
11149             rstr[rslt->length] = '\0';
11150
11151              /* Find where all the components are */
11152              v_sts = vms_split_path
11153                        (aTHX_ rstr,
11154                         &v_spec,
11155                         &v_len,
11156                         &r_spec,
11157                         &r_len,
11158                         &d_spec,
11159                         &d_len,
11160                         &n_spec,
11161                         &n_len,
11162                         &e_spec,
11163                         &e_len,
11164                         &vs_spec,
11165                         &vs_len);
11166
11167             /* If no version on input, truncate the version on output */
11168             if (!hasver && (vs_len > 0)) {
11169                 *vs_spec = '\0';
11170                 vs_len = 0;
11171
11172                 /* No version & a null extension on UNIX handling */
11173                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
11174                     e_len = 0;
11175                     *e_spec = '\0';
11176                 }
11177             }
11178
11179             if (!decc_efs_case_preserve) {
11180                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
11181             }
11182
11183             if (hasdir) {
11184                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
11185                 begin = rstr;
11186             }
11187             else {
11188                 /* Start with the name */
11189                 begin = n_spec;
11190             }
11191             strcat(begin,"\n");
11192             ok = (PerlIO_puts(tmpfp,begin) != EOF);
11193         }
11194         if (cxt) (void)lib$find_file_end(&cxt);
11195         if (ok && sts != RMS$_NMF &&
11196             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
11197         if (!ok) {
11198             if (!(sts & 1)) {
11199                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
11200             }
11201             PerlIO_close(tmpfp);
11202             fp = NULL;
11203         }
11204         else {
11205             PerlIO_rewind(tmpfp);
11206             IoTYPE(io) = IoTYPE_RDONLY;
11207             IoIFP(io) = fp = tmpfp;
11208             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
11209         }
11210     }
11211     Safefree(vmsspec);
11212     Safefree(rslt);
11213     return fp;
11214 }
11215
11216 #ifdef HAS_SYMLINK
11217 static char *
11218 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
11219
11220 void
11221 vms_realpath_fromperl(pTHX_ CV *cv)
11222 {
11223   dXSARGS;
11224   char *fspec, *rslt_spec, *rslt;
11225   STRLEN n_a;
11226
11227   if (!items || items != 1)
11228     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11229
11230   fspec = SvPV(ST(0),n_a);
11231   if (!fspec || !*fspec) XSRETURN_UNDEF;
11232
11233   Newx(rslt_spec, VMS_MAXRSS + 1, char);
11234   rslt = do_vms_realpath(fspec, rslt_spec);
11235   ST(0) = sv_newmortal();
11236   if (rslt != NULL)
11237     sv_usepvn(ST(0),rslt,strlen(rslt));
11238   else
11239     Safefree(rslt_spec);
11240   XSRETURN(1);
11241 }
11242 #endif
11243
11244 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11245 int do_vms_case_tolerant(void);
11246
11247 void
11248 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11249 {
11250   dXSARGS;
11251   ST(0) = boolSV(do_vms_case_tolerant());
11252   XSRETURN(1);
11253 }
11254 #endif
11255
11256 void
11257 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11258                           struct interp_intern *dst)
11259 {
11260     memcpy(dst,src,sizeof(struct interp_intern));
11261 }
11262
11263 void
11264 Perl_sys_intern_clear(pTHX)
11265 {
11266 }
11267
11268 void
11269 Perl_sys_intern_init(pTHX)
11270 {
11271     unsigned int ix = RAND_MAX;
11272     double x;
11273
11274     VMSISH_HUSHED = 0;
11275
11276     /* fix me later to track running under GNV */
11277     /* this allows some limited testing */
11278     MY_POSIX_EXIT = decc_filename_unix_report;
11279
11280     x = (float)ix;
11281     MY_INV_RAND_MAX = 1./x;
11282 }
11283
11284 void
11285 init_os_extras(void)
11286 {
11287   dTHX;
11288   char* file = __FILE__;
11289   if (decc_disable_to_vms_logname_translation) {
11290     no_translate_barewords = TRUE;
11291   } else {
11292     no_translate_barewords = FALSE;
11293   }
11294
11295   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11296   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11297   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11298   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11299   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11300   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11301   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11302   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11303   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11304   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11305   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11306 #ifdef HAS_SYMLINK
11307   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11308 #endif
11309 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11310   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11311 #endif
11312
11313   store_pipelocs(aTHX);         /* will redo any earlier attempts */
11314
11315   return;
11316 }
11317
11318 #ifdef HAS_SYMLINK
11319
11320 #if __CRTL_VER == 80200000
11321 /* This missed getting in to the DECC SDK for 8.2 */
11322 char *realpath(const char *file_name, char * resolved_name, ...);
11323 #endif
11324
11325 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11326 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11327  * The perl fallback routine to provide realpath() is not as efficient
11328  * on OpenVMS.
11329  */
11330 static char *
11331 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11332 {
11333     return realpath(filespec, outbuf);
11334 }
11335
11336 /*}}}*/
11337 /* External entry points */
11338 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11339 { return do_vms_realpath(filespec, outbuf); }
11340 #else
11341 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11342 { return NULL; }
11343 #endif
11344
11345
11346 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11347 /* case_tolerant */
11348
11349 /*{{{int do_vms_case_tolerant(void)*/
11350 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11351  * controlled by a process setting.
11352  */
11353 int do_vms_case_tolerant(void)
11354 {
11355     return vms_process_case_tolerant;
11356 }
11357 /*}}}*/
11358 /* External entry points */
11359 int Perl_vms_case_tolerant(void)
11360 { return do_vms_case_tolerant(); }
11361 #else
11362 int Perl_vms_case_tolerant(void)
11363 { return vms_process_case_tolerant; }
11364 #endif
11365
11366
11367  /* Start of DECC RTL Feature handling */
11368
11369 static int sys_trnlnm
11370    (const char * logname,
11371     char * value,
11372     int value_len)
11373 {
11374     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11375     const unsigned long attr = LNM$M_CASE_BLIND;
11376     struct dsc$descriptor_s name_dsc;
11377     int status;
11378     unsigned short result;
11379     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11380                                 {0, 0, 0, 0}};
11381
11382     name_dsc.dsc$w_length = strlen(logname);
11383     name_dsc.dsc$a_pointer = (char *)logname;
11384     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11385     name_dsc.dsc$b_class = DSC$K_CLASS_S;
11386
11387     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11388
11389     if ($VMS_STATUS_SUCCESS(status)) {
11390
11391          /* Null terminate and return the string */
11392         /*--------------------------------------*/
11393         value[result] = 0;
11394     }
11395
11396     return status;
11397 }
11398
11399 static int sys_crelnm
11400    (const char * logname,
11401     const char * value)
11402 {
11403     int ret_val;
11404     const char * proc_table = "LNM$PROCESS_TABLE";
11405     struct dsc$descriptor_s proc_table_dsc;
11406     struct dsc$descriptor_s logname_dsc;
11407     struct itmlst_3 item_list[2];
11408
11409     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11410     proc_table_dsc.dsc$w_length = strlen(proc_table);
11411     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11412     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11413
11414     logname_dsc.dsc$a_pointer = (char *) logname;
11415     logname_dsc.dsc$w_length = strlen(logname);
11416     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11417     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11418
11419     item_list[0].buflen = strlen(value);
11420     item_list[0].itmcode = LNM$_STRING;
11421     item_list[0].bufadr = (char *)value;
11422     item_list[0].retlen = NULL;
11423
11424     item_list[1].buflen = 0;
11425     item_list[1].itmcode = 0;
11426
11427     ret_val = sys$crelnm
11428                        (NULL,
11429                         (const struct dsc$descriptor_s *)&proc_table_dsc,
11430                         (const struct dsc$descriptor_s *)&logname_dsc,
11431                         NULL,
11432                         (const struct item_list_3 *) item_list);
11433
11434     return ret_val;
11435 }
11436
11437
11438 /* C RTL Feature settings */
11439
11440 static int set_features
11441    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
11442     int (* cli_routine)(void),  /* Not documented */
11443     void *image_info)           /* Not documented */
11444 {
11445     int status;
11446     int s;
11447     int dflt;
11448     char* str;
11449     char val_str[10];
11450 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11451     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
11452     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
11453     unsigned long case_perm;
11454     unsigned long case_image;
11455 #endif
11456
11457     /* Allow an exception to bring Perl into the VMS debugger */
11458     vms_debug_on_exception = 0;
11459     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
11460     if ($VMS_STATUS_SUCCESS(status)) {
11461        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11462          vms_debug_on_exception = 1;
11463        else
11464          vms_debug_on_exception = 0;
11465     }
11466
11467
11468     /* hacks to see if known bugs are still present for testing */
11469
11470     /* Readdir is returning filenames in VMS syntax always */
11471     decc_bug_readdir_efs1 = 1;
11472     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
11473     if ($VMS_STATUS_SUCCESS(status)) {
11474        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11475          decc_bug_readdir_efs1 = 1;
11476        else
11477          decc_bug_readdir_efs1 = 0;
11478     }
11479
11480     /* PCP mode requires creating /dev/null special device file */
11481     decc_bug_devnull = 0;
11482     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
11483     if ($VMS_STATUS_SUCCESS(status)) {
11484        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11485           decc_bug_devnull = 1;
11486        else
11487           decc_bug_devnull = 0;
11488     }
11489
11490     /* fgetname returning a VMS name in UNIX mode */
11491     decc_bug_fgetname = 1;
11492     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
11493     if ($VMS_STATUS_SUCCESS(status)) {
11494       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11495         decc_bug_fgetname = 1;
11496       else
11497         decc_bug_fgetname = 0;
11498     }
11499
11500     /* UNIX directory names with no paths are broken in a lot of places */
11501     decc_dir_barename = 1;
11502     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
11503     if ($VMS_STATUS_SUCCESS(status)) {
11504       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11505         decc_dir_barename = 1;
11506       else
11507         decc_dir_barename = 0;
11508     }
11509
11510 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11511     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
11512     if (s >= 0) {
11513         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
11514         if (decc_disable_to_vms_logname_translation < 0)
11515             decc_disable_to_vms_logname_translation = 0;
11516     }
11517
11518     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
11519     if (s >= 0) {
11520         decc_efs_case_preserve = decc$feature_get_value(s, 1);
11521         if (decc_efs_case_preserve < 0)
11522             decc_efs_case_preserve = 0;
11523     }
11524
11525     s = decc$feature_get_index("DECC$EFS_CHARSET");
11526     if (s >= 0) {
11527         decc_efs_charset = decc$feature_get_value(s, 1);
11528         if (decc_efs_charset < 0)
11529             decc_efs_charset = 0;
11530     }
11531
11532     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
11533     if (s >= 0) {
11534         decc_filename_unix_report = decc$feature_get_value(s, 1);
11535         if (decc_filename_unix_report > 0)
11536             decc_filename_unix_report = 1;
11537         else
11538             decc_filename_unix_report = 0;
11539     }
11540
11541     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
11542     if (s >= 0) {
11543         decc_filename_unix_only = decc$feature_get_value(s, 1);
11544         if (decc_filename_unix_only > 0) {
11545             decc_filename_unix_only = 1;
11546         }
11547         else {
11548             decc_filename_unix_only = 0;
11549         }
11550     }
11551
11552     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
11553     if (s >= 0) {
11554         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
11555         if (decc_filename_unix_no_version < 0)
11556             decc_filename_unix_no_version = 0;
11557     }
11558
11559     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
11560     if (s >= 0) {
11561         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
11562         if (decc_readdir_dropdotnotype < 0)
11563             decc_readdir_dropdotnotype = 0;
11564     }
11565
11566     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
11567     if ($VMS_STATUS_SUCCESS(status)) {
11568         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
11569         if (s >= 0) {
11570             dflt = decc$feature_get_value(s, 4);
11571             if (dflt > 0) {
11572                 decc_disable_posix_root = decc$feature_get_value(s, 1);
11573                 if (decc_disable_posix_root <= 0) {
11574                     decc$feature_set_value(s, 1, 1);
11575                     decc_disable_posix_root = 1;
11576                 }
11577             }
11578             else {
11579                 /* Traditionally Perl assumes this is off */
11580                 decc_disable_posix_root = 1;
11581                 decc$feature_set_value(s, 1, 1);
11582             }
11583         }
11584     }
11585
11586 #if __CRTL_VER >= 80200000
11587     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
11588     if (s >= 0) {
11589         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11590         if (decc_posix_compliant_pathnames < 0)
11591             decc_posix_compliant_pathnames = 0;
11592         if (decc_posix_compliant_pathnames > 4)
11593             decc_posix_compliant_pathnames = 0;
11594     }
11595
11596 #endif
11597 #else
11598     status = sys_trnlnm
11599         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11600     if ($VMS_STATUS_SUCCESS(status)) {
11601         val_str[0] = _toupper(val_str[0]);
11602         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11603            decc_disable_to_vms_logname_translation = 1;
11604         }
11605     }
11606
11607 #ifndef __VAX
11608     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11609     if ($VMS_STATUS_SUCCESS(status)) {
11610         val_str[0] = _toupper(val_str[0]);
11611         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11612            decc_efs_case_preserve = 1;
11613         }
11614     }
11615 #endif
11616
11617     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11618     if ($VMS_STATUS_SUCCESS(status)) {
11619         val_str[0] = _toupper(val_str[0]);
11620         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11621            decc_filename_unix_report = 1;
11622         }
11623     }
11624     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11625     if ($VMS_STATUS_SUCCESS(status)) {
11626         val_str[0] = _toupper(val_str[0]);
11627         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11628            decc_filename_unix_only = 1;
11629            decc_filename_unix_report = 1;
11630         }
11631     }
11632     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11633     if ($VMS_STATUS_SUCCESS(status)) {
11634         val_str[0] = _toupper(val_str[0]);
11635         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11636            decc_filename_unix_no_version = 1;
11637         }
11638     }
11639     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11640     if ($VMS_STATUS_SUCCESS(status)) {
11641         val_str[0] = _toupper(val_str[0]);
11642         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11643            decc_readdir_dropdotnotype = 1;
11644         }
11645     }
11646 #endif
11647
11648 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11649
11650      /* Report true case tolerance */
11651     /*----------------------------*/
11652     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11653     if (!$VMS_STATUS_SUCCESS(status))
11654         case_perm = PPROP$K_CASE_BLIND;
11655     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11656     if (!$VMS_STATUS_SUCCESS(status))
11657         case_image = PPROP$K_CASE_BLIND;
11658     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11659         (case_image == PPROP$K_CASE_SENSITIVE))
11660         vms_process_case_tolerant = 0;
11661
11662 #endif
11663
11664
11665     /* CRTL can be initialized past this point, but not before. */
11666 /*    DECC$CRTL_INIT(); */
11667
11668     return SS$_NORMAL;
11669 }
11670
11671 #ifdef __DECC
11672 /* DECC dependent attributes */
11673 #if __DECC_VER < 60560002
11674 #define relative
11675 #define not_executable
11676 #else
11677 #define relative ,rel
11678 #define not_executable ,noexe
11679 #endif
11680 #pragma nostandard
11681 #pragma extern_model save
11682 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11683 #endif
11684         const __align (LONGWORD) int spare[8] = {0};
11685 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11686 /*                        NOWRT, LONG */
11687 #ifdef __DECC
11688 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11689         nowrt,noshr relative not_executable
11690 #endif
11691 const long vms_cc_features = (const long)set_features;
11692
11693 /*
11694 ** Force a reference to LIB$INITIALIZE to ensure it
11695 ** exists in the image.
11696 */
11697 int lib$initialize(void);
11698 #ifdef __DECC
11699 #pragma extern_model strict_refdef
11700 #endif
11701     int lib_init_ref = (int) lib$initialize;
11702
11703 #ifdef __DECC
11704 #pragma extern_model restore
11705 #pragma standard
11706 #endif
11707
11708 /*  End of vms.c */