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 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  51 #include <efndef.h>
  52 #define NO_EFN EFN$C_ENF
  53 #else
  54 #define NO_EFN 0;
  55 #endif
  56
  57 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  58 int   decc$feature_get_index(const char *name);
  59 char* decc$feature_get_name(int index);
  60 int   decc$feature_get_value(int index, int mode);
  61 int   decc$feature_set_value(int index, int mode, int value);
  62 #else
  63 #include <unixlib.h>
  64 #endif
  65
  66 #pragma member_alignment save
  67 #pragma nomember_alignment longword
  68 struct item_list_3 {
  69         unsigned short len;
  70         unsigned short code;
  71         void * bufadr;
  72         unsigned short * retadr;
  73 };
  74 #pragma member_alignment restore
  75
  76 /* More specific prototype than in starlet_c.h makes programming errors
  77    more visible.
  78  */
  79 #ifdef sys$getdviw
  80 #undef sys$getdviw
  81 #endif
  82 int sys$getdviw
  83        (unsigned long efn,
  84         unsigned short chan,
  85         const struct dsc$descriptor_s * devnam,
  86         const struct item_list_3 * itmlst,
  87         void * iosb,
  88         void * (astadr)(unsigned long),
  89         void * astprm,
  90         void * nullarg);
  91
  92 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  93
  94 static int set_feature_default(const char *name, int value)
  95 {
  96     int status;
  97     int index;
  98
  99     index = decc$feature_get_index(name);
 100
 101     status = decc$feature_set_value(index, 1, value);
 102     if (index == -1 || (status == -1)) {
 103       return -1;
 104     }
 105
 106     status = decc$feature_get_value(index, 1);
 107     if (status != value) {
 108       return -1;
 109     }
 110
 111 return 0;
 112 }
 113 #endif
 114
 115 /* Older versions of ssdef.h don't have these */
 116 #ifndef SS$_INVFILFOROP
 117 #  define SS$_INVFILFOROP 3930
 118 #endif
 119 #ifndef SS$_NOSUCHOBJECT
 120 #  define SS$_NOSUCHOBJECT 2696
 121 #endif
 122
 123 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 124 #define PERLIO_NOT_STDIO 0
 125
 126 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 127  * code below needs to get to the underlying CRTL routines. */
 128 #define DONT_MASK_RTL_CALLS
 129 #include "EXTERN.h"
 130 #include "perl.h"
 131 #include "XSUB.h"
 132 /* Anticipating future expansion in lexical warnings . . . */
 133 #ifndef WARN_INTERNAL
 134 #  define WARN_INTERNAL WARN_MISC
 135 #endif
 136
 137 #ifdef VMS_LONGNAME_SUPPORT
 138 #include <libfildef.h>
 139 #endif
 140
 141 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 142 #  define RTL_USES_UTC 1
 143 #endif
 144
 145
 146 /* gcc's header files don't #define direct access macros
 147  * corresponding to VAXC's variant structs */
 148 #ifdef __GNUC__
 149 #  define uic$v_format uic$r_uic_form.uic$v_format
 150 #  define uic$v_group uic$r_uic_form.uic$v_group
 151 #  define uic$v_member uic$r_uic_form.uic$v_member
 152 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 153 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 154 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 155 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 156 #endif
 157
 158 #if defined(NEED_AN_H_ERRNO)
 159 dEXT int h_errno;
 160 #endif
 161
 162 #ifdef __DECC
 163 #pragma message disable pragma
 164 #pragma member_alignment save
 165 #pragma nomember_alignment longword
 166 #pragma message save
 167 #pragma message disable misalgndmem
 168 #endif
 169 struct itmlst_3 {
 170   unsigned short int buflen;
 171   unsigned short int itmcode;
 172   void *bufadr;
 173   unsigned short int *retlen;
 174 };
 175
 176 struct filescan_itmlst_2 {
 177     unsigned short length;
 178     unsigned short itmcode;
 179     char * component;
 180 };
 181
 182 struct vs_str_st {
 183     unsigned short length;
 184     char str[65536];
 185 };
 186
 187 #ifdef __DECC
 188 #pragma message restore
 189 #pragma member_alignment restore
 190 #endif
 191
 192 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
 193 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
 194 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
 195 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
 196 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
 197 #define do_vms_realpath(a,b)            mp_do_vms_realpath(aTHX_ a,b)
 198 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
 199 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
 200 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 201 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 202 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 203
 204 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
 205 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
 206 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
 207 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
 208
 209 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 210 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 211
 212 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 213  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 214  * the Perl facility.
 215  */
 216 #define PERL_LNM_MAX_ITER 10
 217
 218   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 219 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 220 #define MAX_DCL_SYMBOL          (8192)
 221 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 222 #else
 223 #define MAX_DCL_SYMBOL          (1024)
 224 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 225 #endif
 226
 227 static char *__mystrtolower(char *str)
 228 {
 229   if (str) for (; *str; ++str) *str= tolower(*str);
 230   return str;
 231 }
 232
 233 static struct dsc$descriptor_s fildevdsc =
 234   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 235 static struct dsc$descriptor_s crtlenvdsc =
 236   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 237 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 238 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 239 static struct dsc$descriptor_s **env_tables = defenv;
 240 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 241
 242 /* True if we shouldn't treat barewords as logicals during directory */
 243 /* munching */
 244 static int no_translate_barewords;
 245
 246 #ifndef RTL_USES_UTC
 247 static int tz_updated = 1;
 248 #endif
 249
 250 /* DECC Features that may need to affect how Perl interprets
 251  * displays filename information
 252  */
 253 static int decc_disable_to_vms_logname_translation = 1;
 254 static int decc_disable_posix_root = 1;
 255 int decc_efs_case_preserve = 0;
 256 static int decc_efs_charset = 0;
 257 static int decc_filename_unix_no_version = 0;
 258 static int decc_filename_unix_only = 0;
 259 int decc_filename_unix_report = 0;
 260 int decc_posix_compliant_pathnames = 0;
 261 int decc_readdir_dropdotnotype = 0;
 262 static int vms_process_case_tolerant = 1;
 263
 264 /* bug workarounds if needed */
 265 int decc_bug_readdir_efs1 = 0;
 266 int decc_bug_devnull = 1;
 267 int decc_bug_fgetname = 0;
 268 int decc_dir_barename = 0;
 269
 270 static int vms_debug_on_exception = 0;
 271
 272 /* Is this a UNIX file specification?
 273  *   No longer a simple check with EFS file specs
 274  *   For now, not a full check, but need to
 275  *   handle POSIX ^UP^ specifications
 276  *   Fixing to handle ^/ cases would require
 277  *   changes to many other conversion routines.
 278  */
 279
 280 static int is_unix_filespec(const char *path)
 281 {
 282 int ret_val;
 283 const char * pch1;
 284
 285     ret_val = 0;
 286     if (strncmp(path,"\"^UP^",5) != 0) {
 287         pch1 = strchr(path, '/');
 288         if (pch1 != NULL)
 289             ret_val = 1;
 290         else {
 291
 292             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 293             if (decc_filename_unix_report || decc_filename_unix_only) {
 294             if (strcmp(path,".") == 0)
 295                 ret_val = 1;
 296             }
 297         }
 298     }
 299     return ret_val;
 300 }
 301
 302 /* This handles the expansion of a '^' prefix to the proper character
 303  * in a UNIX file specification.
 304  *
 305  * The output count variable contains the number of characters added
 306  * to the output string.
 307  *
 308  * The return value is the number of characters read from the input
 309  * string
 310  */
 311 static int copy_expand_vms_filename_escape
 312   (char *outspec, const char *inspec, int *output_cnt)
 313 {
 314 int count;
 315 int scnt;
 316
 317     count = 0;
 318     *output_cnt = 0;
 319     if (*inspec == '^') {
 320         inspec++;
 321         switch (*inspec) {
 322         case '.':
 323             /* Non trailing dots should just be passed through */
 324             *outspec = *inspec;
 325             count++;
 326             (*output_cnt)++;
 327             break;
 328         case '_': /* space */
 329             *outspec = ' ';
 330             inspec++;
 331             count++;
 332             (*output_cnt)++;
 333             break;
 334         case 'U': /* Unicode */
 335             inspec++;
 336             count++;
 337             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 338             if (scnt == 4) {
 339                 unsigned int c1, c2;
 340                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 341                 outspec[0] == c1 & 0xff;
 342                 outspec[1] == c2 & 0xff;
 343                 if (scnt > 1) {
 344                     (*output_cnt) += 2;
 345                     count += 4;
 346                 }
 347             }
 348             else {
 349                 /* Error - do best we can to continue */
 350                 *outspec = 'U';
 351                 outspec++;
 352                 (*output_cnt++);
 353                 *outspec = *inspec;
 354                 count++;
 355                 (*output_cnt++);
 356             }
 357             break;
 358         default:
 359             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 360             if (scnt == 2) {
 361                 /* Hex encoded */
 362                 unsigned int c1;
 363                 scnt = sscanf(inspec, "%2x", &c1);
 364                 outspec[0] = c1 & 0xff;
 365                 if (scnt > 0) {
 366                     (*output_cnt++);
 367                     count += 2;
 368                 }
 369             }
 370             else {
 371                 *outspec = *inspec;
 372                 count++;
 373                 (*output_cnt++);
 374             }
 375         }
 376     }
 377     else {
 378         *outspec = *inspec;
 379         count++;
 380         (*output_cnt)++;
 381     }
 382     return count;
 383 }
 384
 385
 386 int SYS$FILESCAN
 387    (const struct dsc$descriptor_s * srcstr,
 388     struct filescan_itmlst_2 * valuelist,
 389     unsigned long * fldflags,
 390     struct dsc$descriptor_s *auxout,
 391     unsigned short * retlen);
 392
 393 /* vms_split_path - Verify that the input file specification is a
 394  * VMS format file specification, and provide pointers to the components of
 395  * it.  With EFS format filenames, this is virtually the only way to
 396  * parse a VMS path specification into components.
 397  *
 398  * If the sum of the components do not add up to the length of the
 399  * string, then the passed file specification is probably a UNIX style
 400  * path.
 401  */
 402 static int vms_split_path
 403    (pTHX_ const char * path,
 404     char * * volume,
 405     int * vol_len,
 406     char * * root,
 407     int * root_len,
 408     char * * dir,
 409     int * dir_len,
 410     char * * name,
 411     int * name_len,
 412     char * * ext,
 413     int * ext_len,
 414     char * * version,
 415     int * ver_len)
 416 {
 417 struct dsc$descriptor path_desc;
 418 int status;
 419 unsigned long flags;
 420 int ret_stat;
 421 struct filescan_itmlst_2 item_list[9];
 422 const int filespec = 0;
 423 const int nodespec = 1;
 424 const int devspec = 2;
 425 const int rootspec = 3;
 426 const int dirspec = 4;
 427 const int namespec = 5;
 428 const int typespec = 6;
 429 const int verspec = 7;
 430
 431     /* Assume the worst for an easy exit */
 432     ret_stat = -1;
 433     *volume = NULL;
 434     *vol_len = 0;
 435     *root = NULL;
 436     *root_len = 0;
 437     *dir = NULL;
 438     *dir_len;
 439     *name = NULL;
 440     *name_len = 0;
 441     *ext = NULL;
 442     *ext_len = 0;
 443     *version = NULL;
 444     *ver_len = 0;
 445
 446     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 447     path_desc.dsc$w_length = strlen(path);
 448     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 449     path_desc.dsc$b_class = DSC$K_CLASS_S;
 450
 451     /* Get the total length, if it is shorter than the string passed
 452      * then this was probably not a VMS formatted file specification
 453      */
 454     item_list[filespec].itmcode = FSCN$_FILESPEC;
 455     item_list[filespec].length = 0;
 456     item_list[filespec].component = NULL;
 457
 458     /* If the node is present, then it gets considered as part of the
 459      * volume name to hopefully make things simple.
 460      */
 461     item_list[nodespec].itmcode = FSCN$_NODE;
 462     item_list[nodespec].length = 0;
 463     item_list[nodespec].component = NULL;
 464
 465     item_list[devspec].itmcode = FSCN$_DEVICE;
 466     item_list[devspec].length = 0;
 467     item_list[devspec].component = NULL;
 468
 469     /* root is a special case,  adding it to either the directory or
 470      * the device components will probalby complicate things for the
 471      * callers of this routine, so leave it separate.
 472      */
 473     item_list[rootspec].itmcode = FSCN$_ROOT;
 474     item_list[rootspec].length = 0;
 475     item_list[rootspec].component = NULL;
 476
 477     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 478     item_list[dirspec].length = 0;
 479     item_list[dirspec].component = NULL;
 480
 481     item_list[namespec].itmcode = FSCN$_NAME;
 482     item_list[namespec].length = 0;
 483     item_list[namespec].component = NULL;
 484
 485     item_list[typespec].itmcode = FSCN$_TYPE;
 486     item_list[typespec].length = 0;
 487     item_list[typespec].component = NULL;
 488
 489     item_list[verspec].itmcode = FSCN$_VERSION;
 490     item_list[verspec].length = 0;
 491     item_list[verspec].component = NULL;
 492
 493     item_list[8].itmcode = 0;
 494     item_list[8].length = 0;
 495     item_list[8].component = NULL;
 496
 497     status = SYS$FILESCAN
 498        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 499         &flags, NULL, NULL);
 500     _ckvmssts(status); /* All failure status values indicate a coding error */
 501
 502     /* If we parsed it successfully these two lengths should be the same */
 503     if (path_desc.dsc$w_length != item_list[filespec].length)
 504         return ret_stat;
 505
 506     /* If we got here, then it is a VMS file specification */
 507     ret_stat = 0;
 508
 509     /* set the volume name */
 510     if (item_list[nodespec].length > 0) {
 511         *volume = item_list[nodespec].component;
 512         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 513     }
 514     else {
 515         *volume = item_list[devspec].component;
 516         *vol_len = item_list[devspec].length;
 517     }
 518
 519     *root = item_list[rootspec].component;
 520     *root_len = item_list[rootspec].length;
 521
 522     *dir = item_list[dirspec].component;
 523     *dir_len = item_list[dirspec].length;
 524
 525     /* Now fun with versions and EFS file specifications
 526      * The parser can not tell the difference when a "." is a version
 527      * delimiter or a part of the file specification.
 528      */
 529     if ((decc_efs_charset) &&
 530         (item_list[verspec].length > 0) &&
 531         (item_list[verspec].component[0] == '.')) {
 532         *name = item_list[namespec].component;
 533         *name_len = item_list[namespec].length + item_list[typespec].length;
 534         *ext = item_list[verspec].component;
 535         *ext_len = item_list[verspec].length;
 536         *version = NULL;
 537         *ver_len = 0;
 538     }
 539     else {
 540         *name = item_list[namespec].component;
 541         *name_len = item_list[namespec].length;
 542         *ext = item_list[typespec].component;
 543         *ext_len = item_list[typespec].length;
 544         *version = item_list[verspec].component;
 545         *ver_len = item_list[verspec].length;
 546     }
 547     return ret_stat;
 548 }
 549
 550
 551 /* my_maxidx
 552  * Routine to retrieve the maximum equivalence index for an input
 553  * logical name.  Some calls to this routine have no knowledge if
 554  * the variable is a logical or not.  So on error we return a max
 555  * index of zero.
 556  */
 557 /*{{{int my_maxidx(const char *lnm) */
 558 static int
 559 my_maxidx(const char *lnm)
 560 {
 561     int status;
 562     int midx;
 563     int attr = LNM$M_CASE_BLIND;
 564     struct dsc$descriptor lnmdsc;
 565     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 566                                 {0, 0, 0, 0}};
 567
 568     lnmdsc.dsc$w_length = strlen(lnm);
 569     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 570     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 571     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 572
 573     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 574     if ((status & 1) == 0)
 575        midx = 0;
 576
 577     return (midx);
 578 }
 579 /*}}}*/
 580
 581 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 582 int
 583 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 584   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 585 {
 586     const char *cp1;
 587     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 588     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 589     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 590     int midx;
 591     unsigned char acmode;
 592     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 593                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 594     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 595                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 596                                  {0, 0, 0, 0}};
 597     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 598 #if defined(PERL_IMPLICIT_CONTEXT)
 599     pTHX = NULL;
 600     if (PL_curinterp) {
 601       aTHX = PERL_GET_INTERP;
 602     } else {
 603       aTHX = NULL;
 604     }
 605 #endif
 606
 607     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 608       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 609     }
 610     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 611       *cp2 = _toupper(*cp1);
 612       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 613         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 614         return 0;
 615       }
 616     }
 617     lnmdsc.dsc$w_length = cp1 - lnm;
 618     lnmdsc.dsc$a_pointer = uplnm;
 619     uplnm[lnmdsc.dsc$w_length] = '\0';
 620     secure = flags & PERL__TRNENV_SECURE;
 621     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 622     if (!tabvec || !*tabvec) tabvec = env_tables;
 623
 624     for (curtab = 0; tabvec[curtab]; curtab++) {
 625       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 626         if (!ivenv && !secure) {
 627           char *eq, *end;
 628           int i;
 629           if (!environ) {
 630             ivenv = 1;
 631             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 632             continue;
 633           }
 634           retsts = SS$_NOLOGNAM;
 635           for (i = 0; environ[i]; i++) {
 636             if ((eq = strchr(environ[i],'=')) &&
 637                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 638                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 639               eq++;
 640               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 641               if (!eqvlen) continue;
 642               retsts = SS$_NORMAL;
 643               break;
 644             }
 645           }
 646           if (retsts != SS$_NOLOGNAM) break;
 647         }
 648       }
 649       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 650                !str$case_blind_compare(&tmpdsc,&clisym)) {
 651         if (!ivsym && !secure) {
 652           unsigned short int deflen = LNM$C_NAMLENGTH;
 653           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 654           /* dynamic dsc to accomodate possible long value */
 655           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 656           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 657           if (retsts & 1) {
 658             if (eqvlen > MAX_DCL_SYMBOL) {
 659               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 660               eqvlen = MAX_DCL_SYMBOL;
 661               /* Special hack--we might be called before the interpreter's */
 662               /* fully initialized, in which case either thr or PL_curcop */
 663               /* might be bogus. We have to check, since ckWARN needs them */
 664               /* both to be valid if running threaded */
 665                 if (ckWARN(WARN_MISC)) {
 666                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 667                 }
 668             }
 669             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 670           }
 671           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 672           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 673           if (retsts == LIB$_NOSUCHSYM) continue;
 674           break;
 675         }
 676       }
 677       else if (!ivlnm) {
 678         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 679           midx = my_maxidx(lnm);
 680           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 681             lnmlst[1].bufadr = cp2;
 682             eqvlen = 0;
 683             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 684             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 685             if (retsts == SS$_NOLOGNAM) break;
 686             /* PPFs have a prefix */
 687             if (
 688 #if INTSIZE == 4
 689                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 690 #endif
 691                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 692                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 693                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 694                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 695                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 696               memmove(eqv,eqv+4,eqvlen-4);
 697               eqvlen -= 4;
 698             }
 699             cp2 += eqvlen;
 700             *cp2 = '\0';
 701           }
 702           if ((retsts == SS$_IVLOGNAM) ||
 703               (retsts == SS$_NOLOGNAM)) { continue; }
 704         }
 705         else {
 706           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 707           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 708           if (retsts == SS$_NOLOGNAM) continue;
 709           eqv[eqvlen] = '\0';
 710         }
 711         eqvlen = strlen(eqv);
 712         break;
 713       }
 714     }
 715     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 716     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 717              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 718              retsts == SS$_NOLOGNAM) {
 719       set_errno(EINVAL);  set_vaxc_errno(retsts);
 720     }
 721     else _ckvmssts(retsts);
 722     return 0;
 723 }  /* end of vmstrnenv */
 724 /*}}}*/
 725
 726 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 727 /* Define as a function so we can access statics. */
 728 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 729 {
 730   return vmstrnenv(lnm,eqv,idx,fildev,
 731 #ifdef SECURE_INTERNAL_GETENV
 732                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 733 #else
 734                    0
 735 #endif
 736                                                                               );
 737 }
 738 /*}}}*/
 739
 740 /* my_getenv
 741  * Note: Uses Perl temp to store result so char * can be returned to
 742  * caller; this pointer will be invalidated at next Perl statement
 743  * transition.
 744  * We define this as a function rather than a macro in terms of my_getenv_len()
 745  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 746  * allocate SVs).
 747  */
 748 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 749 char *
 750 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 751 {
 752     const char *cp1;
 753     static char *__my_getenv_eqv = NULL;
 754     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 755     unsigned long int idx = 0;
 756     int trnsuccess, success, secure, saverr, savvmserr;
 757     int midx, flags;
 758     SV *tmpsv;
 759
 760     midx = my_maxidx(lnm) + 1;
 761
 762     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 763       /* Set up a temporary buffer for the return value; Perl will
 764        * clean it up at the next statement transition */
 765       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 766       if (!tmpsv) return NULL;
 767       eqv = SvPVX(tmpsv);
 768     }
 769     else {
 770       /* Assume no interpreter ==> single thread */
 771       if (__my_getenv_eqv != NULL) {
 772         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 773       }
 774       else {
 775         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 776       }
 777       eqv = __my_getenv_eqv;
 778     }
 779
 780     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 781     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 782       int len;
 783       getcwd(eqv,LNM$C_NAMLENGTH);
 784
 785       len = strlen(eqv);
 786
 787       /* Get rid of "000000/ in rooted filespecs */
 788       if (len > 7) {
 789         char * zeros;
 790         zeros = strstr(eqv, "/000000/");
 791         if (zeros != NULL) {
 792           int mlen;
 793           mlen = len - (zeros - eqv) - 7;
 794           memmove(zeros, &zeros[7], mlen);
 795           len = len - 7;
 796           eqv[len] = '\0';
 797         }
 798       }
 799       return eqv;
 800     }
 801     else {
 802       /* Impose security constraints only if tainting */
 803       if (sys) {
 804         /* Impose security constraints only if tainting */
 805         secure = PL_curinterp ? PL_tainting : will_taint;
 806         saverr = errno;  savvmserr = vaxc$errno;
 807       }
 808       else {
 809         secure = 0;
 810       }
 811
 812       flags =
 813 #ifdef SECURE_INTERNAL_GETENV
 814               secure ? PERL__TRNENV_SECURE : 0
 815 #else
 816               0
 817 #endif
 818       ;
 819
 820       /* For the getenv interface we combine all the equivalence names
 821        * of a search list logical into one value to acquire a maximum
 822        * value length of 255*128 (assuming %ENV is using logicals).
 823        */
 824       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 825
 826       /* If the name contains a semicolon-delimited index, parse it
 827        * off and make sure we only retrieve the equivalence name for
 828        * that index.  */
 829       if ((cp2 = strchr(lnm,';')) != NULL) {
 830         strcpy(uplnm,lnm);
 831         uplnm[cp2-lnm] = '\0';
 832         idx = strtoul(cp2+1,NULL,0);
 833         lnm = uplnm;
 834         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 835       }
 836
 837       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
 838
 839       /* Discard NOLOGNAM on internal calls since we're often looking
 840        * for an optional name, and this "error" often shows up as the
 841        * (bogus) exit status for a die() call later on.  */
 842       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 843       return success ? eqv : Nullch;
 844     }
 845
 846 }  /* end of my_getenv() */
 847 /*}}}*/
 848
 849
 850 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 851 char *
 852 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 853 {
 854     const char *cp1;
 855     char *buf, *cp2;
 856     unsigned long idx = 0;
 857     int midx, flags;
 858     static char *__my_getenv_len_eqv = NULL;
 859     int secure, saverr, savvmserr;
 860     SV *tmpsv;
 861
 862     midx = my_maxidx(lnm) + 1;
 863
 864     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 865       /* Set up a temporary buffer for the return value; Perl will
 866        * clean it up at the next statement transition */
 867       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 868       if (!tmpsv) return NULL;
 869       buf = SvPVX(tmpsv);
 870     }
 871     else {
 872       /* Assume no interpreter ==> single thread */
 873       if (__my_getenv_len_eqv != NULL) {
 874         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 875       }
 876       else {
 877         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 878       }
 879       buf = __my_getenv_len_eqv;
 880     }
 881
 882     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 883     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 884     char * zeros;
 885
 886       getcwd(buf,LNM$C_NAMLENGTH);
 887       *len = strlen(buf);
 888
 889       /* Get rid of "000000/ in rooted filespecs */
 890       if (*len > 7) {
 891       zeros = strstr(buf, "/000000/");
 892       if (zeros != NULL) {
 893         int mlen;
 894         mlen = *len - (zeros - buf) - 7;
 895         memmove(zeros, &zeros[7], mlen);
 896         *len = *len - 7;
 897         buf[*len] = '\0';
 898         }
 899       }
 900       return buf;
 901     }
 902     else {
 903       if (sys) {
 904         /* Impose security constraints only if tainting */
 905         secure = PL_curinterp ? PL_tainting : will_taint;
 906         saverr = errno;  savvmserr = vaxc$errno;
 907       }
 908       else {
 909         secure = 0;
 910       }
 911
 912       flags =
 913 #ifdef SECURE_INTERNAL_GETENV
 914               secure ? PERL__TRNENV_SECURE : 0
 915 #else
 916               0
 917 #endif
 918       ;
 919
 920       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 921
 922       if ((cp2 = strchr(lnm,';')) != NULL) {
 923         strcpy(buf,lnm);
 924         buf[cp2-lnm] = '\0';
 925         idx = strtoul(cp2+1,NULL,0);
 926         lnm = buf;
 927         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 928       }
 929
 930       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
 931
 932       /* Get rid of "000000/ in rooted filespecs */
 933       if (*len > 7) {
 934       char * zeros;
 935         zeros = strstr(buf, "/000000/");
 936         if (zeros != NULL) {
 937           int mlen;
 938           mlen = *len - (zeros - buf) - 7;
 939           memmove(zeros, &zeros[7], mlen);
 940           *len = *len - 7;
 941           buf[*len] = '\0';
 942         }
 943       }
 944
 945       /* Discard NOLOGNAM on internal calls since we're often looking
 946        * for an optional name, and this "error" often shows up as the
 947        * (bogus) exit status for a die() call later on.  */
 948       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 949       return *len ? buf : Nullch;
 950     }
 951
 952 }  /* end of my_getenv_len() */
 953 /*}}}*/
 954
 955 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 956
 957 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 958
 959 /*{{{ void prime_env_iter() */
 960 void
 961 prime_env_iter(void)
 962 /* Fill the %ENV associative array with all logical names we can
 963  * find, in preparation for iterating over it.
 964  */
 965 {
 966   static int primed = 0;
 967   HV *seenhv = NULL, *envhv;
 968   SV *sv = NULL;
 969   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 970   unsigned short int chan;
 971 #ifndef CLI$M_TRUSTED
 972 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 973 #endif
 974   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 975   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 976   long int i;
 977   bool have_sym = FALSE, have_lnm = FALSE;
 978   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 979   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 980   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 981   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 982   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 983 #if defined(PERL_IMPLICIT_CONTEXT)
 984   pTHX;
 985 #endif
 986 #if defined(USE_ITHREADS)
 987   static perl_mutex primenv_mutex;
 988   MUTEX_INIT(&primenv_mutex);
 989 #endif
 990
 991 #if defined(PERL_IMPLICIT_CONTEXT)
 992     /* We jump through these hoops because we can be called at */
 993     /* platform-specific initialization time, which is before anything is */
 994     /* set up--we can't even do a plain dTHX since that relies on the */
 995     /* interpreter structure to be initialized */
 996     if (PL_curinterp) {
 997       aTHX = PERL_GET_INTERP;
 998     } else {
 999       aTHX = NULL;
1000     }
1001 #endif
1002
1003   if (primed || !PL_envgv) return;
1004   MUTEX_LOCK(&primenv_mutex);
1005   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1006   envhv = GvHVn(PL_envgv);
1007   /* Perform a dummy fetch as an lval to insure that the hash table is
1008    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1009   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1010
1011   for (i = 0; env_tables[i]; i++) {
1012      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1013          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1014      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1015   }
1016   if (have_sym || have_lnm) {
1017     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1018     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1019     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1020     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1021   }
1022
1023   for (i--; i >= 0; i--) {
1024     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1025       char *start;
1026       int j;
1027       for (j = 0; environ[j]; j++) {
1028         if (!(start = strchr(environ[j],'='))) {
1029           if (ckWARN(WARN_INTERNAL))
1030             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1031         }
1032         else {
1033           start++;
1034           sv = newSVpv(start,0);
1035           SvTAINTED_on(sv);
1036           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1037         }
1038       }
1039       continue;
1040     }
1041     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1042              !str$case_blind_compare(&tmpdsc,&clisym)) {
1043       strcpy(cmd,"Show Symbol/Global *");
1044       cmddsc.dsc$w_length = 20;
1045       if (env_tables[i]->dsc$w_length == 12 &&
1046           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1047           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1048       flags = defflags | CLI$M_NOLOGNAM;
1049     }
1050     else {
1051       strcpy(cmd,"Show Logical *");
1052       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1053         strcat(cmd," /Table=");
1054         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1055         cmddsc.dsc$w_length = strlen(cmd);
1056       }
1057       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1058       flags = defflags | CLI$M_NOCLISYM;
1059     }
1060
1061     /* Create a new subprocess to execute each command, to exclude the
1062      * remote possibility that someone could subvert a mbx or file used
1063      * to write multiple commands to a single subprocess.
1064      */
1065     do {
1066       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1067                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1068       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1069       defflags &= ~CLI$M_TRUSTED;
1070     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1071     _ckvmssts(retsts);
1072     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1073     if (seenhv) SvREFCNT_dec(seenhv);
1074     seenhv = newHV();
1075     while (1) {
1076       char *cp1, *cp2, *key;
1077       unsigned long int sts, iosb[2], retlen, keylen;
1078       register U32 hash;
1079
1080       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1081       if (sts & 1) sts = iosb[0] & 0xffff;
1082       if (sts == SS$_ENDOFFILE) {
1083         int wakect = 0;
1084         while (substs == 0) { sys$hiber(); wakect++;}
1085         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1086         _ckvmssts(substs);
1087         break;
1088       }
1089       _ckvmssts(sts);
1090       retlen = iosb[0] >> 16;
1091       if (!retlen) continue;  /* blank line */
1092       buf[retlen] = '\0';
1093       if (iosb[1] != subpid) {
1094         if (iosb[1]) {
1095           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1096         }
1097         continue;
1098       }
1099       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1100         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1101
1102       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1103       if (*cp1 == '(' || /* Logical name table name */
1104           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1105       if (*cp1 == '"') cp1++;
1106       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1107       key = cp1;  keylen = cp2 - cp1;
1108       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1109       while (*cp2 && *cp2 != '=') cp2++;
1110       while (*cp2 && *cp2 == '=') cp2++;
1111       while (*cp2 && *cp2 == ' ') cp2++;
1112       if (*cp2 == '"') {  /* String translation; may embed "" */
1113         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1114         cp2++;  cp1--; /* Skip "" surrounding translation */
1115       }
1116       else {  /* Numeric translation */
1117         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1118         cp1--;  /* stop on last non-space char */
1119       }
1120       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1121         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1122         continue;
1123       }
1124       PERL_HASH(hash,key,keylen);
1125
1126       if (cp1 == cp2 && *cp2 == '.') {
1127         /* A single dot usually means an unprintable character, such as a null
1128          * to indicate a zero-length value.  Get the actual value to make sure.
1129          */
1130         char lnm[LNM$C_NAMLENGTH+1];
1131         char eqv[MAX_DCL_SYMBOL+1];
1132         strncpy(lnm, key, keylen);
1133         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1134         sv = newSVpvn(eqv, strlen(eqv));
1135       }
1136       else {
1137         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1138       }
1139
1140       SvTAINTED_on(sv);
1141       hv_store(envhv,key,keylen,sv,hash);
1142       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1143     }
1144     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1145       /* get the PPFs for this process, not the subprocess */
1146       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1147       char eqv[LNM$C_NAMLENGTH+1];
1148       int trnlen, i;
1149       for (i = 0; ppfs[i]; i++) {
1150         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1151         sv = newSVpv(eqv,trnlen);
1152         SvTAINTED_on(sv);
1153         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1154       }
1155     }
1156   }
1157   primed = 1;
1158   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1159   if (buf) Safefree(buf);
1160   if (seenhv) SvREFCNT_dec(seenhv);
1161   MUTEX_UNLOCK(&primenv_mutex);
1162   return;
1163
1164 }  /* end of prime_env_iter */
1165 /*}}}*/
1166
1167
1168 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1169 /* Define or delete an element in the same "environment" as
1170  * vmstrnenv().  If an element is to be deleted, it's removed from
1171  * the first place it's found.  If it's to be set, it's set in the
1172  * place designated by the first element of the table vector.
1173  * Like setenv() returns 0 for success, non-zero on error.
1174  */
1175 int
1176 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1177 {
1178     const char *cp1;
1179     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1180     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1181     int nseg = 0, j;
1182     unsigned long int retsts, usermode = PSL$C_USER;
1183     struct itmlst_3 *ile, *ilist;
1184     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1185                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1186                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1187     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1188     $DESCRIPTOR(local,"_LOCAL");
1189
1190     if (!lnm) {
1191         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1192         return SS$_IVLOGNAM;
1193     }
1194
1195     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1196       *cp2 = _toupper(*cp1);
1197       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1198         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1199         return SS$_IVLOGNAM;
1200       }
1201     }
1202     lnmdsc.dsc$w_length = cp1 - lnm;
1203     if (!tabvec || !*tabvec) tabvec = env_tables;
1204
1205     if (!eqv) {  /* we're deleting n element */
1206       for (curtab = 0; tabvec[curtab]; curtab++) {
1207         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1208         int i;
1209           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1210             if ((cp1 = strchr(environ[i],'=')) &&
1211                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1212                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1213 #ifdef HAS_SETENV
1214               return setenv(lnm,"",1) ? vaxc$errno : 0;
1215             }
1216           }
1217           ivenv = 1; retsts = SS$_NOLOGNAM;
1218 #else
1219               if (ckWARN(WARN_INTERNAL))
1220                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1221               ivenv = 1; retsts = SS$_NOSUCHPGM;
1222               break;
1223             }
1224           }
1225 #endif
1226         }
1227         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1228                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1229           unsigned int symtype;
1230           if (tabvec[curtab]->dsc$w_length == 12 &&
1231               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1232               !str$case_blind_compare(&tmpdsc,&local))
1233             symtype = LIB$K_CLI_LOCAL_SYM;
1234           else symtype = LIB$K_CLI_GLOBAL_SYM;
1235           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1236           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1237           if (retsts == LIB$_NOSUCHSYM) continue;
1238           break;
1239         }
1240         else if (!ivlnm) {
1241           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1242           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1243           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1244           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1245           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1246         }
1247       }
1248     }
1249     else {  /* we're defining a value */
1250       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1251 #ifdef HAS_SETENV
1252         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1253 #else
1254         if (ckWARN(WARN_INTERNAL))
1255           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1256         retsts = SS$_NOSUCHPGM;
1257 #endif
1258       }
1259       else {
1260         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1261         eqvdsc.dsc$w_length  = strlen(eqv);
1262         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1263             !str$case_blind_compare(&tmpdsc,&clisym)) {
1264           unsigned int symtype;
1265           if (tabvec[0]->dsc$w_length == 12 &&
1266               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1267                !str$case_blind_compare(&tmpdsc,&local))
1268             symtype = LIB$K_CLI_LOCAL_SYM;
1269           else symtype = LIB$K_CLI_GLOBAL_SYM;
1270           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1271         }
1272         else {
1273           if (!*eqv) eqvdsc.dsc$w_length = 1;
1274           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1275
1276             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1277             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1278               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1279                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1280               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1281               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1282             }
1283
1284             Newx(ilist,nseg+1,struct itmlst_3);
1285             ile = ilist;
1286             if (!ile) {
1287               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1288               return SS$_INSFMEM;
1289             }
1290             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1291
1292             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1293               ile->itmcode = LNM$_STRING;
1294               ile->bufadr = c;
1295               if ((j+1) == nseg) {
1296                 ile->buflen = strlen(c);
1297                 /* in case we are truncating one that's too long */
1298                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1299               }
1300               else {
1301                 ile->buflen = LNM$C_NAMLENGTH;
1302               }
1303             }
1304
1305             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1306             Safefree (ilist);
1307           }
1308           else {
1309             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1310           }
1311         }
1312       }
1313     }
1314     if (!(retsts & 1)) {
1315       switch (retsts) {
1316         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1317         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1318           set_errno(EVMSERR); break;
1319         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1320         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1321           set_errno(EINVAL); break;
1322         case SS$_NOPRIV:
1323           set_errno(EACCES); break;
1324         default:
1325           _ckvmssts(retsts);
1326           set_errno(EVMSERR);
1327        }
1328        set_vaxc_errno(retsts);
1329        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1330     }
1331     else {
1332       /* We reset error values on success because Perl does an hv_fetch()
1333        * before each hv_store(), and if the thing we're setting didn't
1334        * previously exist, we've got a leftover error message.  (Of course,
1335        * this fails in the face of
1336        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1337        * in that the error reported in $! isn't spurious,
1338        * but it's right more often than not.)
1339        */
1340       set_errno(0); set_vaxc_errno(retsts);
1341       return 0;
1342     }
1343
1344 }  /* end of vmssetenv() */
1345 /*}}}*/
1346
1347 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1348 /* This has to be a function since there's a prototype for it in proto.h */
1349 void
1350 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1351 {
1352     if (lnm && *lnm) {
1353       int len = strlen(lnm);
1354       if  (len == 7) {
1355         char uplnm[8];
1356         int i;
1357         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1358         if (!strcmp(uplnm,"DEFAULT")) {
1359           if (eqv && *eqv) my_chdir(eqv);
1360           return;
1361         }
1362     }
1363 #ifndef RTL_USES_UTC
1364     if (len == 6 || len == 2) {
1365       char uplnm[7];
1366       int i;
1367       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1368       uplnm[len] = '\0';
1369       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1370       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1371     }
1372 #endif
1373   }
1374   (void) vmssetenv(lnm,eqv,NULL);
1375 }
1376 /*}}}*/
1377
1378 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1379 /*  vmssetuserlnm
1380  *  sets a user-mode logical in the process logical name table
1381  *  used for redirection of sys$error
1382  */
1383 void
1384 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1385 {
1386     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1387     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1388     unsigned long int iss, attr = LNM$M_CONFINE;
1389     unsigned char acmode = PSL$C_USER;
1390     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1391                                  {0, 0, 0, 0}};
1392     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1393     d_name.dsc$w_length = strlen(name);
1394
1395     lnmlst[0].buflen = strlen(eqv);
1396     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1397
1398     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1399     if (!(iss&1)) lib$signal(iss);
1400 }
1401 /*}}}*/
1402
1403
1404 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1405 /* my_crypt - VMS password hashing
1406  * my_crypt() provides an interface compatible with the Unix crypt()
1407  * C library function, and uses sys$hash_password() to perform VMS
1408  * password hashing.  The quadword hashed password value is returned
1409  * as a NUL-terminated 8 character string.  my_crypt() does not change
1410  * the case of its string arguments; in order to match the behavior
1411  * of LOGINOUT et al., alphabetic characters in both arguments must
1412  *  be upcased by the caller.
1413  *
1414  * - fix me to call ACM services when available
1415  */
1416 char *
1417 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1418 {
1419 #   ifndef UAI$C_PREFERRED_ALGORITHM
1420 #     define UAI$C_PREFERRED_ALGORITHM 127
1421 #   endif
1422     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1423     unsigned short int salt = 0;
1424     unsigned long int sts;
1425     struct const_dsc {
1426         unsigned short int dsc$w_length;
1427         unsigned char      dsc$b_type;
1428         unsigned char      dsc$b_class;
1429         const char *       dsc$a_pointer;
1430     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1431        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1432     struct itmlst_3 uailst[3] = {
1433         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1434         { sizeof salt, UAI$_SALT,    &salt, 0},
1435         { 0,           0,            NULL,  NULL}};
1436     static char hash[9];
1437
1438     usrdsc.dsc$w_length = strlen(usrname);
1439     usrdsc.dsc$a_pointer = usrname;
1440     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1441       switch (sts) {
1442         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1443           set_errno(EACCES);
1444           break;
1445         case RMS$_RNF:
1446           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1447           break;
1448         default:
1449           set_errno(EVMSERR);
1450       }
1451       set_vaxc_errno(sts);
1452       if (sts != RMS$_RNF) return NULL;
1453     }
1454
1455     txtdsc.dsc$w_length = strlen(textpasswd);
1456     txtdsc.dsc$a_pointer = textpasswd;
1457     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1458       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1459     }
1460
1461     return (char *) hash;
1462
1463 }  /* end of my_crypt() */
1464 /*}}}*/
1465
1466
1467 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1468 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1469 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1470
1471 /* fixup barenames that are directories for internal use.
1472  * There have been problems with the consistent handling of UNIX
1473  * style directory names when routines are presented with a name that
1474  * has no directory delimitors at all.  So this routine will eventually
1475  * fix the issue.
1476  */
1477 static char * fixup_bare_dirnames(const char * name)
1478 {
1479   if (decc_disable_to_vms_logname_translation) {
1480 /* fix me */
1481   }
1482   return NULL;
1483 }
1484
1485 /* mp_do_kill_file
1486  * A little hack to get around a bug in some implemenation of remove()
1487  * that do not know how to delete a directory
1488  *
1489  * Delete any file to which user has control access, regardless of whether
1490  * delete access is explicitly allowed.
1491  * Limitations: User must have write access to parent directory.
1492  *              Does not block signals or ASTs; if interrupted in midstream
1493  *              may leave file with an altered ACL.
1494  * HANDLE WITH CARE!
1495  */
1496 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1497 static int
1498 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1499 {
1500     char *vmsname, *rspec;
1501     char *remove_name;
1502     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1503     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1504     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1505     struct myacedef {
1506       unsigned char myace$b_length;
1507       unsigned char myace$b_type;
1508       unsigned short int myace$w_flags;
1509       unsigned long int myace$l_access;
1510       unsigned long int myace$l_ident;
1511     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1512                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1513       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1514      struct itmlst_3
1515        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1516                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1517        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1518        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1519        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1520        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1521
1522     /* Expand the input spec using RMS, since the CRTL remove() and
1523      * system services won't do this by themselves, so we may miss
1524      * a file "hiding" behind a logical name or search list. */
1525     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1526     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1527
1528     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1529       PerlMem_free(vmsname);
1530       return -1;
1531     }
1532
1533     if (decc_posix_compliant_pathnames) {
1534       /* In POSIX mode, we prefer to remove the UNIX name */
1535       rspec = vmsname;
1536       remove_name = (char *)name;
1537     }
1538     else {
1539       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1540       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1541       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1542         PerlMem_free(rspec);
1543         PerlMem_free(vmsname);
1544         return -1;
1545       }
1546       PerlMem_free(vmsname);
1547       remove_name = rspec;
1548     }
1549
1550 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1551     if (dirflag != 0) {
1552         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1553           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1554           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1555
1556           do_pathify_dirspec(name, remove_name, 0);
1557           if (!rmdir(remove_name)) {
1558
1559             PerlMem_free(remove_name);
1560             PerlMem_free(rspec);
1561             return 0;   /* Can we just get rid of it? */
1562           }
1563         }
1564         else {
1565           if (!rmdir(remove_name)) {
1566             PerlMem_free(rspec);
1567             return 0;   /* Can we just get rid of it? */
1568           }
1569         }
1570     }
1571     else
1572 #endif
1573       if (!remove(remove_name)) {
1574         PerlMem_free(rspec);
1575         return 0;   /* Can we just get rid of it? */
1576       }
1577
1578     /* If not, can changing protections help? */
1579     if (vaxc$errno != RMS$_PRV) {
1580       PerlMem_free(rspec);
1581       return -1;
1582     }
1583
1584     /* No, so we get our own UIC to use as a rights identifier,
1585      * and the insert an ACE at the head of the ACL which allows us
1586      * to delete the file.
1587      */
1588     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1589     fildsc.dsc$w_length = strlen(rspec);
1590     fildsc.dsc$a_pointer = rspec;
1591     cxt = 0;
1592     newace.myace$l_ident = oldace.myace$l_ident;
1593     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1594       switch (aclsts) {
1595         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1596           set_errno(ENOENT); break;
1597         case RMS$_DIR:
1598           set_errno(ENOTDIR); break;
1599         case RMS$_DEV:
1600           set_errno(ENODEV); break;
1601         case RMS$_SYN: case SS$_INVFILFOROP:
1602           set_errno(EINVAL); break;
1603         case RMS$_PRV:
1604           set_errno(EACCES); break;
1605         default:
1606           _ckvmssts(aclsts);
1607       }
1608       set_vaxc_errno(aclsts);
1609       PerlMem_free(rspec);
1610       return -1;
1611     }
1612     /* Grab any existing ACEs with this identifier in case we fail */
1613     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1614     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1615                     || fndsts == SS$_NOMOREACE ) {
1616       /* Add the new ACE . . . */
1617       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1618         goto yourroom;
1619
1620 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1621       if (dirflag != 0)
1622         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1623           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1624           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1625
1626           do_pathify_dirspec(name, remove_name, 0);
1627           rmsts = rmdir(remove_name);
1628           PerlMem_free(remove_name);
1629         }
1630         else {
1631         rmsts = rmdir(remove_name);
1632         }
1633       else
1634 #endif
1635         rmsts = remove(remove_name);
1636       if (rmsts) {
1637         /* We blew it - dir with files in it, no write priv for
1638          * parent directory, etc.  Put things back the way they were. */
1639         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1640           goto yourroom;
1641         if (fndsts & 1) {
1642           addlst[0].bufadr = &oldace;
1643           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1644             goto yourroom;
1645         }
1646       }
1647     }
1648
1649     yourroom:
1650     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1651     /* We just deleted it, so of course it's not there.  Some versions of
1652      * VMS seem to return success on the unlock operation anyhow (after all
1653      * the unlock is successful), but others don't.
1654      */
1655     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1656     if (aclsts & 1) aclsts = fndsts;
1657     if (!(aclsts & 1)) {
1658       set_errno(EVMSERR);
1659       set_vaxc_errno(aclsts);
1660       PerlMem_free(rspec);
1661       return -1;
1662     }
1663
1664     PerlMem_free(rspec);
1665     return rmsts;
1666
1667 }  /* end of kill_file() */
1668 /*}}}*/
1669
1670
1671 /*{{{int do_rmdir(char *name)*/
1672 int
1673 Perl_do_rmdir(pTHX_ const char *name)
1674 {
1675     char dirfile[NAM$C_MAXRSS+1];
1676     int retval;
1677     Stat_t st;
1678
1679     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1680     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1681     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1682     return retval;
1683
1684 }  /* end of do_rmdir */
1685 /*}}}*/
1686
1687 /* kill_file
1688  * Delete any file to which user has control access, regardless of whether
1689  * delete access is explicitly allowed.
1690  * Limitations: User must have write access to parent directory.
1691  *              Does not block signals or ASTs; if interrupted in midstream
1692  *              may leave file with an altered ACL.
1693  * HANDLE WITH CARE!
1694  */
1695 /*{{{int kill_file(char *name)*/
1696 int
1697 Perl_kill_file(pTHX_ const char *name)
1698 {
1699     char rspec[NAM$C_MAXRSS+1];
1700     char *tspec;
1701     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1702     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1703     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1704     struct myacedef {
1705       unsigned char myace$b_length;
1706       unsigned char myace$b_type;
1707       unsigned short int myace$w_flags;
1708       unsigned long int myace$l_access;
1709       unsigned long int myace$l_ident;
1710     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1711                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1712       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1713      struct itmlst_3
1714        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1715                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1716        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1717        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1718        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1719        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1720
1721     /* Expand the input spec using RMS, since the CRTL remove() and
1722      * system services won't do this by themselves, so we may miss
1723      * a file "hiding" behind a logical name or search list. */
1724     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS);
1725     if (tspec == NULL) return -1;
1726     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1727     /* If not, can changing protections help? */
1728     if (vaxc$errno != RMS$_PRV) return -1;
1729
1730     /* No, so we get our own UIC to use as a rights identifier,
1731      * and the insert an ACE at the head of the ACL which allows us
1732      * to delete the file.
1733      */
1734     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1735     fildsc.dsc$w_length = strlen(rspec);
1736     fildsc.dsc$a_pointer = rspec;
1737     cxt = 0;
1738     newace.myace$l_ident = oldace.myace$l_ident;
1739     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1740       switch (aclsts) {
1741         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1742           set_errno(ENOENT); break;
1743         case RMS$_DIR:
1744           set_errno(ENOTDIR); break;
1745         case RMS$_DEV:
1746           set_errno(ENODEV); break;
1747         case RMS$_SYN: case SS$_INVFILFOROP:
1748           set_errno(EINVAL); break;
1749         case RMS$_PRV:
1750           set_errno(EACCES); break;
1751         default:
1752           _ckvmssts(aclsts);
1753       }
1754       set_vaxc_errno(aclsts);
1755       return -1;
1756     }
1757     /* Grab any existing ACEs with this identifier in case we fail */
1758     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1759     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1760                     || fndsts == SS$_NOMOREACE ) {
1761       /* Add the new ACE . . . */
1762       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1763         goto yourroom;
1764       if ((rmsts = remove(name))) {
1765         /* We blew it - dir with files in it, no write priv for
1766          * parent directory, etc.  Put things back the way they were. */
1767         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1768           goto yourroom;
1769         if (fndsts & 1) {
1770           addlst[0].bufadr = &oldace;
1771           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1772             goto yourroom;
1773         }
1774       }
1775     }
1776
1777     yourroom:
1778     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1779     /* We just deleted it, so of course it's not there.  Some versions of
1780      * VMS seem to return success on the unlock operation anyhow (after all
1781      * the unlock is successful), but others don't.
1782      */
1783     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1784     if (aclsts & 1) aclsts = fndsts;
1785     if (!(aclsts & 1)) {
1786       set_errno(EVMSERR);
1787       set_vaxc_errno(aclsts);
1788       return -1;
1789     }
1790
1791     return rmsts;
1792
1793 }  /* end of kill_file() */
1794 /*}}}*/
1795
1796
1797 /*{{{int my_mkdir(char *,Mode_t)*/
1798 int
1799 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1800 {
1801   STRLEN dirlen = strlen(dir);
1802
1803   /* zero length string sometimes gives ACCVIO */
1804   if (dirlen == 0) return -1;
1805
1806   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1807    * null file name/type.  However, it's commonplace under Unix,
1808    * so we'll allow it for a gain in portability.
1809    */
1810   if (dir[dirlen-1] == '/') {
1811     char *newdir = savepvn(dir,dirlen-1);
1812     int ret = mkdir(newdir,mode);
1813     Safefree(newdir);
1814     return ret;
1815   }
1816   else return mkdir(dir,mode);
1817 }  /* end of my_mkdir */
1818 /*}}}*/
1819
1820 /*{{{int my_chdir(char *)*/
1821 int
1822 Perl_my_chdir(pTHX_ const char *dir)
1823 {
1824   STRLEN dirlen = strlen(dir);
1825
1826   /* zero length string sometimes gives ACCVIO */
1827   if (dirlen == 0) return -1;
1828   const char *dir1;
1829
1830   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1831    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
1832    * so that existing scripts do not need to be changed.
1833    */
1834   dir1 = dir;
1835   while ((dirlen > 0) && (*dir1 == ' ')) {
1836     dir1++;
1837     dirlen--;
1838   }
1839
1840   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1841    * that implies
1842    * null file name/type.  However, it's commonplace under Unix,
1843    * so we'll allow it for a gain in portability.
1844    *
1845    * - Preview- '/' will be valid soon on VMS
1846    */
1847   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1848     char *newdir = savepvn(dir1,dirlen-1);
1849     int ret = chdir(newdir);
1850     Safefree(newdir);
1851     return ret;
1852   }
1853   else return chdir(dir1);
1854 }  /* end of my_chdir */
1855 /*}}}*/
1856
1857
1858 /*{{{FILE *my_tmpfile()*/
1859 FILE *
1860 my_tmpfile(void)
1861 {
1862   FILE *fp;
1863   char *cp;
1864
1865   if ((fp = tmpfile())) return fp;
1866
1867   cp = PerlMem_malloc(L_tmpnam+24);
1868   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1869
1870   if (decc_filename_unix_only == 0)
1871     strcpy(cp,"Sys$Scratch:");
1872   else
1873     strcpy(cp,"/tmp/");
1874   tmpnam(cp+strlen(cp));
1875   strcat(cp,".Perltmp");
1876   fp = fopen(cp,"w+","fop=dlt");
1877   PerlMem_free(cp);
1878   return fp;
1879 }
1880 /*}}}*/
1881
1882
1883 #ifndef HOMEGROWN_POSIX_SIGNALS
1884 /*
1885  * The C RTL's sigaction fails to check for invalid signal numbers so we
1886  * help it out a bit.  The docs are correct, but the actual routine doesn't
1887  * do what the docs say it will.
1888  */
1889 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1890 int
1891 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1892                    struct sigaction* oact)
1893 {
1894   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1895         SETERRNO(EINVAL, SS$_INVARG);
1896         return -1;
1897   }
1898   return sigaction(sig, act, oact);
1899 }
1900 /*}}}*/
1901 #endif
1902
1903 #ifdef KILL_BY_SIGPRC
1904 #include <errnodef.h>
1905
1906 /* We implement our own kill() using the undocumented system service
1907    sys$sigprc for one of two reasons:
1908
1909    1.) If the kill() in an older CRTL uses sys$forcex, causing the
1910    target process to do a sys$exit, which usually can't be handled
1911    gracefully...certainly not by Perl and the %SIG{} mechanism.
1912
1913    2.) If the kill() in the CRTL can't be called from a signal
1914    handler without disappearing into the ether, i.e., the signal
1915    it purportedly sends is never trapped. Still true as of VMS 7.3.
1916
1917    sys$sigprc has the same parameters as sys$forcex, but throws an exception
1918    in the target process rather than calling sys$exit.
1919
1920    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1921    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1922    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
1923    with condition codes C$_SIG0+nsig*8, catching the exception on the
1924    target process and resignaling with appropriate arguments.
1925
1926    But we don't have that VMS 7.0+ exception handler, so if you
1927    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
1928
1929    Also note that SIGTERM is listed in the docs as being "unimplemented",
1930    yet always seems to be signaled with a VMS condition code of 4 (and
1931    correctly handled for that code).  So we hardwire it in.
1932
1933    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1934    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
1935    than signalling with an unrecognized (and unhandled by CRTL) code.
1936 */
1937
1938 #define _MY_SIG_MAX 17
1939
1940 static unsigned int
1941 Perl_sig_to_vmscondition_int(int sig)
1942 {
1943     static unsigned int sig_code[_MY_SIG_MAX+1] =
1944     {
1945         0,                  /*  0 ZERO     */
1946         SS$_HANGUP,         /*  1 SIGHUP   */
1947         SS$_CONTROLC,       /*  2 SIGINT   */
1948         SS$_CONTROLY,       /*  3 SIGQUIT  */
1949         SS$_RADRMOD,        /*  4 SIGILL   */
1950         SS$_BREAK,          /*  5 SIGTRAP  */
1951         SS$_OPCCUS,         /*  6 SIGABRT  */
1952         SS$_COMPAT,         /*  7 SIGEMT   */
1953 #ifdef __VAX
1954         SS$_FLTOVF,         /*  8 SIGFPE VAX */
1955 #else
1956         SS$_HPARITH,        /*  8 SIGFPE AXP */
1957 #endif
1958         SS$_ABORT,          /*  9 SIGKILL  */
1959         SS$_ACCVIO,         /* 10 SIGBUS   */
1960         SS$_ACCVIO,         /* 11 SIGSEGV  */
1961         SS$_BADPARAM,       /* 12 SIGSYS   */
1962         SS$_NOMBX,          /* 13 SIGPIPE  */
1963         SS$_ASTFLT,         /* 14 SIGALRM  */
1964         4,                  /* 15 SIGTERM  */
1965         0,                  /* 16 SIGUSR1  */
1966         0                   /* 17 SIGUSR2  */
1967     };
1968
1969 #if __VMS_VER >= 60200000
1970     static int initted = 0;
1971     if (!initted) {
1972         initted = 1;
1973         sig_code[16] = C$_SIGUSR1;
1974         sig_code[17] = C$_SIGUSR2;
1975     }
1976 #endif
1977
1978     if (sig < _SIG_MIN) return 0;
1979     if (sig > _MY_SIG_MAX) return 0;
1980     return sig_code[sig];
1981 }
1982
1983 unsigned int
1984 Perl_sig_to_vmscondition(int sig)
1985 {
1986 #ifdef SS$_DEBUG
1987     if (vms_debug_on_exception != 0)
1988         lib$signal(SS$_DEBUG);
1989 #endif
1990     return Perl_sig_to_vmscondition_int(sig);
1991 }
1992
1993
1994 int
1995 Perl_my_kill(int pid, int sig)
1996 {
1997     dTHX;
1998     int iss;
1999     unsigned int code;
2000     int sys$sigprc(unsigned int *pidadr,
2001                      struct dsc$descriptor_s *prcname,
2002                      unsigned int code);
2003
2004      /* sig 0 means validate the PID */
2005     /*------------------------------*/
2006     if (sig == 0) {
2007         const unsigned long int jpicode = JPI$_PID;
2008         pid_t ret_pid;
2009         int status;
2010         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2011         if ($VMS_STATUS_SUCCESS(status))
2012            return 0;
2013         switch (status) {
2014         case SS$_NOSUCHNODE:
2015         case SS$_UNREACHABLE:
2016         case SS$_NONEXPR:
2017            errno = ESRCH;
2018            break;
2019         case SS$_NOPRIV:
2020            errno = EPERM;
2021            break;
2022         default:
2023            errno = EVMSERR;
2024         }
2025         vaxc$errno=status;
2026         return -1;
2027     }
2028
2029     code = Perl_sig_to_vmscondition_int(sig);
2030
2031     if (!code) {
2032         SETERRNO(EINVAL, SS$_BADPARAM);
2033         return -1;
2034     }
2035
2036     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2037      * signals are to be sent to multiple processes.
2038      *  pid = 0 - all processes in group except ones that the system exempts
2039      *  pid = -1 - all processes except ones that the system exempts
2040      *  pid = -n - all processes in group (abs(n)) except ...
2041      * For now, just report as not supported.
2042      */
2043
2044     if (pid <= 0) {
2045         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2046         return -1;
2047     }
2048
2049     iss = sys$sigprc((unsigned int *)&pid,0,code);
2050     if (iss&1) return 0;
2051
2052     switch (iss) {
2053       case SS$_NOPRIV:
2054         set_errno(EPERM);  break;
2055       case SS$_NONEXPR:
2056       case SS$_NOSUCHNODE:
2057       case SS$_UNREACHABLE:
2058         set_errno(ESRCH);  break;
2059       case SS$_INSFMEM:
2060         set_errno(ENOMEM); break;
2061       default:
2062         _ckvmssts(iss);
2063         set_errno(EVMSERR);
2064     }
2065     set_vaxc_errno(iss);
2066
2067     return -1;
2068 }
2069 #endif
2070
2071 /* Routine to convert a VMS status code to a UNIX status code.
2072 ** More tricky than it appears because of conflicting conventions with
2073 ** existing code.
2074 **
2075 ** VMS status codes are a bit mask, with the least significant bit set for
2076 ** success.
2077 **
2078 ** Special UNIX status of EVMSERR indicates that no translation is currently
2079 ** available, and programs should check the VMS status code.
2080 **
2081 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2082 ** decoding.
2083 */
2084
2085 #ifndef C_FACILITY_NO
2086 #define C_FACILITY_NO 0x350000
2087 #endif
2088 #ifndef DCL_IVVERB
2089 #define DCL_IVVERB 0x38090
2090 #endif
2091
2092 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2093 {
2094 int facility;
2095 int fac_sp;
2096 int msg_no;
2097 int msg_status;
2098 int unix_status;
2099
2100   /* Assume the best or the worst */
2101   if (vms_status & STS$M_SUCCESS)
2102     unix_status = 0;
2103   else
2104     unix_status = EVMSERR;
2105
2106   msg_status = vms_status & ~STS$M_CONTROL;
2107
2108   facility = vms_status & STS$M_FAC_NO;
2109   fac_sp = vms_status & STS$M_FAC_SP;
2110   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2111
2112   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2113     switch(msg_no) {
2114     case SS$_NORMAL:
2115         unix_status = 0;
2116         break;
2117     case SS$_ACCVIO:
2118         unix_status = EFAULT;
2119         break;
2120     case SS$_DEVOFFLINE:
2121         unix_status = EBUSY;
2122         break;
2123     case SS$_CLEARED:
2124         unix_status = ENOTCONN;
2125         break;
2126     case SS$_IVCHAN:
2127     case SS$_IVLOGNAM:
2128     case SS$_BADPARAM:
2129     case SS$_IVLOGTAB:
2130     case SS$_NOLOGNAM:
2131     case SS$_NOLOGTAB:
2132     case SS$_INVFILFOROP:
2133     case SS$_INVARG:
2134     case SS$_NOSUCHID:
2135     case SS$_IVIDENT:
2136         unix_status = EINVAL;
2137         break;
2138     case SS$_UNSUPPORTED:
2139         unix_status = ENOTSUP;
2140         break;
2141     case SS$_FILACCERR:
2142     case SS$_NOGRPPRV:
2143     case SS$_NOSYSPRV:
2144         unix_status = EACCES;
2145         break;
2146     case SS$_DEVICEFULL:
2147         unix_status = ENOSPC;
2148         break;
2149     case SS$_NOSUCHDEV:
2150         unix_status = ENODEV;
2151         break;
2152     case SS$_NOSUCHFILE:
2153     case SS$_NOSUCHOBJECT:
2154         unix_status = ENOENT;
2155         break;
2156     case SS$_ABORT:                                 /* Fatal case */
2157     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2158     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2159         unix_status = EINTR;
2160         break;
2161     case SS$_BUFFEROVF:
2162         unix_status = E2BIG;
2163         break;
2164     case SS$_INSFMEM:
2165         unix_status = ENOMEM;
2166         break;
2167     case SS$_NOPRIV:
2168         unix_status = EPERM;
2169         break;
2170     case SS$_NOSUCHNODE:
2171     case SS$_UNREACHABLE:
2172         unix_status = ESRCH;
2173         break;
2174     case SS$_NONEXPR:
2175         unix_status = ECHILD;
2176         break;
2177     default:
2178         if ((facility == 0) && (msg_no < 8)) {
2179           /* These are not real VMS status codes so assume that they are
2180           ** already UNIX status codes
2181           */
2182           unix_status = msg_no;
2183           break;
2184         }
2185     }
2186   }
2187   else {
2188     /* Translate a POSIX exit code to a UNIX exit code */
2189     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2190         unix_status = (msg_no & 0x07F8) >> 3;
2191     }
2192     else {
2193
2194          /* Documented traditional behavior for handling VMS child exits */
2195         /*--------------------------------------------------------------*/
2196         if (child_flag != 0) {
2197
2198              /* Success / Informational return 0 */
2199             /*----------------------------------*/
2200             if (msg_no & STS$K_SUCCESS)
2201                 return 0;
2202
2203              /* Warning returns 1 */
2204             /*-------------------*/
2205             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2206                 return 1;
2207
2208              /* Everything else pass through the severity bits */
2209             /*------------------------------------------------*/
2210             return (msg_no & STS$M_SEVERITY);
2211         }
2212
2213          /* Normal VMS status to ERRNO mapping attempt */
2214         /*--------------------------------------------*/
2215         switch(msg_status) {
2216         /* case RMS$_EOF: */ /* End of File */
2217         case RMS$_FNF:  /* File Not Found */
2218         case RMS$_DNF:  /* Dir Not Found */
2219                 unix_status = ENOENT;
2220                 break;
2221         case RMS$_RNF:  /* Record Not Found */
2222                 unix_status = ESRCH;
2223                 break;
2224         case RMS$_DIR:
2225                 unix_status = ENOTDIR;
2226                 break;
2227         case RMS$_DEV:
2228                 unix_status = ENODEV;
2229                 break;
2230         case RMS$_IFI:
2231         case RMS$_FAC:
2232         case RMS$_ISI:
2233                 unix_status = EBADF;
2234                 break;
2235         case RMS$_FEX:
2236                 unix_status = EEXIST;
2237                 break;
2238         case RMS$_SYN:
2239         case RMS$_FNM:
2240         case LIB$_INVSTRDES:
2241         case LIB$_INVARG:
2242         case LIB$_NOSUCHSYM:
2243         case LIB$_INVSYMNAM:
2244         case DCL_IVVERB:
2245                 unix_status = EINVAL;
2246                 break;
2247         case CLI$_BUFOVF:
2248         case RMS$_RTB:
2249         case CLI$_TKNOVF:
2250         case CLI$_RSLOVF:
2251                 unix_status = E2BIG;
2252                 break;
2253         case RMS$_PRV:  /* No privilege */
2254         case RMS$_ACC:  /* ACP file access failed */
2255         case RMS$_WLK:  /* Device write locked */
2256                 unix_status = EACCES;
2257                 break;
2258         /* case RMS$_NMF: */  /* No more files */
2259         }
2260     }
2261   }
2262
2263   return unix_status;
2264 }
2265
2266 /* Try to guess at what VMS error status should go with a UNIX errno
2267  * value.  This is hard to do as there could be many possible VMS
2268  * error statuses that caused the errno value to be set.
2269  */
2270
2271 int Perl_unix_status_to_vms(int unix_status)
2272 {
2273 int test_unix_status;
2274
2275      /* Trivial cases first */
2276     /*---------------------*/
2277     if (unix_status == EVMSERR)
2278         return vaxc$errno;
2279
2280      /* Is vaxc$errno sane? */
2281     /*---------------------*/
2282     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2283     if (test_unix_status == unix_status)
2284         return vaxc$errno;
2285
2286      /* If way out of range, must be VMS code already */
2287     /*-----------------------------------------------*/
2288     if (unix_status > EVMSERR)
2289         return unix_status;
2290
2291      /* If out of range, punt */
2292     /*-----------------------*/
2293     if (unix_status > __ERRNO_MAX)
2294         return SS$_ABORT;
2295
2296
2297      /* Ok, now we have to do it the hard way. */
2298     /*----------------------------------------*/
2299     switch(unix_status) {
2300     case 0:     return SS$_NORMAL;
2301     case EPERM: return SS$_NOPRIV;
2302     case ENOENT: return SS$_NOSUCHOBJECT;
2303     case ESRCH: return SS$_UNREACHABLE;
2304     case EINTR: return SS$_ABORT;
2305     /* case EIO: */
2306     /* case ENXIO:  */
2307     case E2BIG: return SS$_BUFFEROVF;
2308     /* case ENOEXEC */
2309     case EBADF: return RMS$_IFI;
2310     case ECHILD: return SS$_NONEXPR;
2311     /* case EAGAIN */
2312     case ENOMEM: return SS$_INSFMEM;
2313     case EACCES: return SS$_FILACCERR;
2314     case EFAULT: return SS$_ACCVIO;
2315     /* case ENOTBLK */
2316     case EBUSY: return SS$_DEVOFFLINE;
2317     case EEXIST: return RMS$_FEX;
2318     /* case EXDEV */
2319     case ENODEV: return SS$_NOSUCHDEV;
2320     case ENOTDIR: return RMS$_DIR;
2321     /* case EISDIR */
2322     case EINVAL: return SS$_INVARG;
2323     /* case ENFILE */
2324     /* case EMFILE */
2325     /* case ENOTTY */
2326     /* case ETXTBSY */
2327     /* case EFBIG */
2328     case ENOSPC: return SS$_DEVICEFULL;
2329     case ESPIPE: return LIB$_INVARG;
2330     /* case EROFS: */
2331     /* case EMLINK: */
2332     /* case EPIPE: */
2333     /* case EDOM */
2334     case ERANGE: return LIB$_INVARG;
2335     /* case EWOULDBLOCK */
2336     /* case EINPROGRESS */
2337     /* case EALREADY */
2338     /* case ENOTSOCK */
2339     /* case EDESTADDRREQ */
2340     /* case EMSGSIZE */
2341     /* case EPROTOTYPE */
2342     /* case ENOPROTOOPT */
2343     /* case EPROTONOSUPPORT */
2344     /* case ESOCKTNOSUPPORT */
2345     /* case EOPNOTSUPP */
2346     /* case EPFNOSUPPORT */
2347     /* case EAFNOSUPPORT */
2348     /* case EADDRINUSE */
2349     /* case EADDRNOTAVAIL */
2350     /* case ENETDOWN */
2351     /* case ENETUNREACH */
2352     /* case ENETRESET */
2353     /* case ECONNABORTED */
2354     /* case ECONNRESET */
2355     /* case ENOBUFS */
2356     /* case EISCONN */
2357     case ENOTCONN: return SS$_CLEARED;
2358     /* case ESHUTDOWN */
2359     /* case ETOOMANYREFS */
2360     /* case ETIMEDOUT */
2361     /* case ECONNREFUSED */
2362     /* case ELOOP */
2363     /* case ENAMETOOLONG */
2364     /* case EHOSTDOWN */
2365     /* case EHOSTUNREACH */
2366     /* case ENOTEMPTY */
2367     /* case EPROCLIM */
2368     /* case EUSERS  */
2369     /* case EDQUOT  */
2370     /* case ENOMSG  */
2371     /* case EIDRM */
2372     /* case EALIGN */
2373     /* case ESTALE */
2374     /* case EREMOTE */
2375     /* case ENOLCK */
2376     /* case ENOSYS */
2377     /* case EFTYPE */
2378     /* case ECANCELED */
2379     /* case EFAIL */
2380     /* case EINPROG */
2381     case ENOTSUP:
2382         return SS$_UNSUPPORTED;
2383     /* case EDEADLK */
2384     /* case ENWAIT */
2385     /* case EILSEQ */
2386     /* case EBADCAT */
2387     /* case EBADMSG */
2388     /* case EABANDONED */
2389     default:
2390         return SS$_ABORT; /* punt */
2391     }
2392
2393   return SS$_ABORT; /* Should not get here */
2394 }
2395
2396
2397 /* default piping mailbox size */
2398 #define PERL_BUFSIZ        512
2399
2400
2401 static void
2402 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2403 {
2404   unsigned long int mbxbufsiz;
2405   static unsigned long int syssize = 0;
2406   unsigned long int dviitm = DVI$_DEVNAM;
2407   char csize[LNM$C_NAMLENGTH+1];
2408   int sts;
2409
2410   if (!syssize) {
2411     unsigned long syiitm = SYI$_MAXBUF;
2412     /*
2413      * Get the SYSGEN parameter MAXBUF
2414      *
2415      * If the logical 'PERL_MBX_SIZE' is defined
2416      * use the value of the logical instead of PERL_BUFSIZ, but
2417      * keep the size between 128 and MAXBUF.
2418      *
2419      */
2420     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2421   }
2422
2423   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2424       mbxbufsiz = atoi(csize);
2425   } else {
2426       mbxbufsiz = PERL_BUFSIZ;
2427   }
2428   if (mbxbufsiz < 128) mbxbufsiz = 128;
2429   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2430
2431   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2432
2433   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2434   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2435
2436 }  /* end of create_mbx() */
2437
2438
2439 /*{{{  my_popen and my_pclose*/
2440
2441 typedef struct _iosb           IOSB;
2442 typedef struct _iosb*         pIOSB;
2443 typedef struct _pipe           Pipe;
2444 typedef struct _pipe*         pPipe;
2445 typedef struct pipe_details    Info;
2446 typedef struct pipe_details*  pInfo;
2447 typedef struct _srqp            RQE;
2448 typedef struct _srqp*          pRQE;
2449 typedef struct _tochildbuf      CBuf;
2450 typedef struct _tochildbuf*    pCBuf;
2451
2452 struct _iosb {
2453     unsigned short status;
2454     unsigned short count;
2455     unsigned long  dvispec;
2456 };
2457
2458 #pragma member_alignment save
2459 #pragma nomember_alignment quadword
2460 struct _srqp {          /* VMS self-relative queue entry */
2461     unsigned long qptr[2];
2462 };
2463 #pragma member_alignment restore
2464 static RQE  RQE_ZERO = {0,0};
2465
2466 struct _tochildbuf {
2467     RQE             q;
2468     int             eof;
2469     unsigned short  size;
2470     char            *buf;
2471 };
2472
2473 struct _pipe {
2474     RQE            free;
2475     RQE            wait;
2476     int            fd_out;
2477     unsigned short chan_in;
2478     unsigned short chan_out;
2479     char          *buf;
2480     unsigned int   bufsize;
2481     IOSB           iosb;
2482     IOSB           iosb2;
2483     int           *pipe_done;
2484     int            retry;
2485     int            type;
2486     int            shut_on_empty;
2487     int            need_wake;
2488     pPipe         *home;
2489     pInfo          info;
2490     pCBuf          curr;
2491     pCBuf          curr2;
2492 #if defined(PERL_IMPLICIT_CONTEXT)
2493     void            *thx;           /* Either a thread or an interpreter */
2494                                     /* pointer, depending on how we're built */
2495 #endif
2496 };
2497
2498
2499 struct pipe_details
2500 {
2501     pInfo           next;
2502     PerlIO *fp;  /* file pointer to pipe mailbox */
2503     int useFILE; /* using stdio, not perlio */
2504     int pid;   /* PID of subprocess */
2505     int mode;  /* == 'r' if pipe open for reading */
2506     int done;  /* subprocess has completed */
2507     int waiting; /* waiting for completion/closure */
2508     int             closing;        /* my_pclose is closing this pipe */
2509     unsigned long   completion;     /* termination status of subprocess */
2510     pPipe           in;             /* pipe in to sub */
2511     pPipe           out;            /* pipe out of sub */
2512     pPipe           err;            /* pipe of sub's sys$error */
2513     int             in_done;        /* true when in pipe finished */
2514     int             out_done;
2515     int             err_done;
2516 };
2517
2518 struct exit_control_block
2519 {
2520     struct exit_control_block *flink;
2521     unsigned long int   (*exit_routine)();
2522     unsigned long int arg_count;
2523     unsigned long int *status_address;
2524     unsigned long int exit_status;
2525 };
2526
2527 typedef struct _closed_pipes    Xpipe;
2528 typedef struct _closed_pipes*  pXpipe;
2529
2530 struct _closed_pipes {
2531     int             pid;            /* PID of subprocess */
2532     unsigned long   completion;     /* termination status of subprocess */
2533 };
2534 #define NKEEPCLOSED 50
2535 static Xpipe closed_list[NKEEPCLOSED];
2536 static int   closed_index = 0;
2537 static int   closed_num = 0;
2538
2539 #define RETRY_DELAY     "0 ::0.20"
2540 #define MAX_RETRY              50
2541
2542 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2543 static unsigned long mypid;
2544 static unsigned long delaytime[2];
2545
2546 static pInfo open_pipes = NULL;
2547 static $DESCRIPTOR(nl_desc, "NL:");
2548
2549 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2550
2551
2552
2553 static unsigned long int
2554 pipe_exit_routine(pTHX)
2555 {
2556     pInfo info;
2557     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2558     int sts, did_stuff, need_eof, j;
2559
2560     /*
2561         flush any pending i/o
2562     */
2563     info = open_pipes;
2564     while (info) {
2565         if (info->fp) {
2566            if (!info->useFILE)
2567                PerlIO_flush(info->fp);   /* first, flush data */
2568            else
2569                fflush((FILE *)info->fp);
2570         }
2571         info = info->next;
2572     }
2573
2574     /*
2575      next we try sending an EOF...ignore if doesn't work, make sure we
2576      don't hang
2577     */
2578     did_stuff = 0;
2579     info = open_pipes;
2580
2581     while (info) {
2582       int need_eof;
2583       _ckvmssts_noperl(sys$setast(0));
2584       if (info->in && !info->in->shut_on_empty) {
2585         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2586                           0, 0, 0, 0, 0, 0));
2587         info->waiting = 1;
2588         did_stuff = 1;
2589       }
2590       _ckvmssts_noperl(sys$setast(1));
2591       info = info->next;
2592     }
2593
2594     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2595
2596     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2597         int nwait = 0;
2598
2599         info = open_pipes;
2600         while (info) {
2601           _ckvmssts_noperl(sys$setast(0));
2602           if (info->waiting && info->done)
2603                 info->waiting = 0;
2604           nwait += info->waiting;
2605           _ckvmssts_noperl(sys$setast(1));
2606           info = info->next;
2607         }
2608         if (!nwait) break;
2609         sleep(1);
2610     }
2611
2612     did_stuff = 0;
2613     info = open_pipes;
2614     while (info) {
2615       _ckvmssts_noperl(sys$setast(0));
2616       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2617         sts = sys$forcex(&info->pid,0,&abort);
2618         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2619         did_stuff = 1;
2620       }
2621       _ckvmssts_noperl(sys$setast(1));
2622       info = info->next;
2623     }
2624
2625     /* again, wait for effect */
2626
2627     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2628         int nwait = 0;
2629
2630         info = open_pipes;
2631         while (info) {
2632           _ckvmssts_noperl(sys$setast(0));
2633           if (info->waiting && info->done)
2634                 info->waiting = 0;
2635           nwait += info->waiting;
2636           _ckvmssts_noperl(sys$setast(1));
2637           info = info->next;
2638         }
2639         if (!nwait) break;
2640         sleep(1);
2641     }
2642
2643     info = open_pipes;
2644     while (info) {
2645       _ckvmssts_noperl(sys$setast(0));
2646       if (!info->done) {  /* We tried to be nice . . . */
2647         sts = sys$delprc(&info->pid,0);
2648         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2649       }
2650       _ckvmssts_noperl(sys$setast(1));
2651       info = info->next;
2652     }
2653
2654     while(open_pipes) {
2655       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2656       else if (!(sts & 1)) retsts = sts;
2657     }
2658     return retsts;
2659 }
2660
2661 static struct exit_control_block pipe_exitblock =
2662        {(struct exit_control_block *) 0,
2663         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2664
2665 static void pipe_mbxtofd_ast(pPipe p);
2666 static void pipe_tochild1_ast(pPipe p);
2667 static void pipe_tochild2_ast(pPipe p);
2668
2669 static void
2670 popen_completion_ast(pInfo info)
2671 {
2672   pInfo i = open_pipes;
2673   int iss;
2674   int sts;
2675   pXpipe x;
2676
2677   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2678   closed_list[closed_index].pid = info->pid;
2679   closed_list[closed_index].completion = info->completion;
2680   closed_index++;
2681   if (closed_index == NKEEPCLOSED)
2682     closed_index = 0;
2683   closed_num++;
2684
2685   while (i) {
2686     if (i == info) break;
2687     i = i->next;
2688   }
2689   if (!i) return;       /* unlinked, probably freed too */
2690
2691   info->done = TRUE;
2692
2693 /*
2694     Writing to subprocess ...
2695             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2696
2697             chan_out may be waiting for "done" flag, or hung waiting
2698             for i/o completion to child...cancel the i/o.  This will
2699             put it into "snarf mode" (done but no EOF yet) that discards
2700             input.
2701
2702     Output from subprocess (stdout, stderr) needs to be flushed and
2703     shut down.   We try sending an EOF, but if the mbx is full the pipe
2704     routine should still catch the "shut_on_empty" flag, telling it to
2705     use immediate-style reads so that "mbx empty" -> EOF.
2706
2707
2708 */
2709   if (info->in && !info->in_done) {               /* only for mode=w */
2710         if (info->in->shut_on_empty && info->in->need_wake) {
2711             info->in->need_wake = FALSE;
2712             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2713         } else {
2714             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2715         }
2716   }
2717
2718   if (info->out && !info->out_done) {             /* were we also piping output? */
2719       info->out->shut_on_empty = TRUE;
2720       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2721       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2722       _ckvmssts_noperl(iss);
2723   }
2724
2725   if (info->err && !info->err_done) {        /* we were piping stderr */
2726         info->err->shut_on_empty = TRUE;
2727         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2728         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2729         _ckvmssts_noperl(iss);
2730   }
2731   _ckvmssts_noperl(sys$setef(pipe_ef));
2732
2733 }
2734
2735 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2736 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2737
2738 /*
2739     we actually differ from vmstrnenv since we use this to
2740     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2741     are pointing to the same thing
2742 */
2743
2744 static unsigned short
2745 popen_translate(pTHX_ char *logical, char *result)
2746 {
2747     int iss;
2748     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2749     $DESCRIPTOR(d_log,"");
2750     struct _il3 {
2751         unsigned short length;
2752         unsigned short code;
2753         char *         buffer_addr;
2754         unsigned short *retlenaddr;
2755     } itmlst[2];
2756     unsigned short l, ifi;
2757
2758     d_log.dsc$a_pointer = logical;
2759     d_log.dsc$w_length  = strlen(logical);
2760
2761     itmlst[0].code = LNM$_STRING;
2762     itmlst[0].length = 255;
2763     itmlst[0].buffer_addr = result;
2764     itmlst[0].retlenaddr = &l;
2765
2766     itmlst[1].code = 0;
2767     itmlst[1].length = 0;
2768     itmlst[1].buffer_addr = 0;
2769     itmlst[1].retlenaddr = 0;
2770
2771     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2772     if (iss == SS$_NOLOGNAM) {
2773         iss = SS$_NORMAL;
2774         l = 0;
2775     }
2776     if (!(iss&1)) lib$signal(iss);
2777     result[l] = '\0';
2778 /*
2779     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
2780     strip it off and return the ifi, if any
2781 */
2782     ifi  = 0;
2783     if (result[0] == 0x1b && result[1] == 0x00) {
2784         memmove(&ifi,result+2,2);
2785         strcpy(result,result+4);
2786     }
2787     return ifi;     /* this is the RMS internal file id */
2788 }
2789
2790 static void pipe_infromchild_ast(pPipe p);
2791
2792 /*
2793     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2794     inside an AST routine without worrying about reentrancy and which Perl
2795     memory allocator is being used.
2796
2797     We read data and queue up the buffers, then spit them out one at a
2798     time to the output mailbox when the output mailbox is ready for one.
2799
2800 */
2801 #define INITIAL_TOCHILDQUEUE  2
2802
2803 static pPipe
2804 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2805 {
2806     pPipe p;
2807     pCBuf b;
2808     char mbx1[64], mbx2[64];
2809     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2810                                       DSC$K_CLASS_S, mbx1},
2811                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2812                                       DSC$K_CLASS_S, mbx2};
2813     unsigned int dviitm = DVI$_DEVBUFSIZ;
2814     int j, n;
2815
2816     n = sizeof(Pipe);
2817     _ckvmssts(lib$get_vm(&n, &p));
2818
2819     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2820     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2821     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2822
2823     p->buf           = 0;
2824     p->shut_on_empty = FALSE;
2825     p->need_wake     = FALSE;
2826     p->type          = 0;
2827     p->retry         = 0;
2828     p->iosb.status   = SS$_NORMAL;
2829     p->iosb2.status  = SS$_NORMAL;
2830     p->free          = RQE_ZERO;
2831     p->wait          = RQE_ZERO;
2832     p->curr          = 0;
2833     p->curr2         = 0;
2834     p->info          = 0;
2835 #ifdef PERL_IMPLICIT_CONTEXT
2836     p->thx           = aTHX;
2837 #endif
2838
2839     n = sizeof(CBuf) + p->bufsize;
2840
2841     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2842         _ckvmssts(lib$get_vm(&n, &b));
2843         b->buf = (char *) b + sizeof(CBuf);
2844         _ckvmssts(lib$insqhi(b, &p->free));
2845     }
2846
2847     pipe_tochild2_ast(p);
2848     pipe_tochild1_ast(p);
2849     strcpy(wmbx, mbx1);
2850     strcpy(rmbx, mbx2);
2851     return p;
2852 }
2853
2854 /*  reads the MBX Perl is writing, and queues */
2855
2856 static void
2857 pipe_tochild1_ast(pPipe p)
2858 {
2859     pCBuf b = p->curr;
2860     int iss = p->iosb.status;
2861     int eof = (iss == SS$_ENDOFFILE);
2862     int sts;
2863 #ifdef PERL_IMPLICIT_CONTEXT
2864     pTHX = p->thx;
2865 #endif
2866
2867     if (p->retry) {
2868         if (eof) {
2869             p->shut_on_empty = TRUE;
2870             b->eof     = TRUE;
2871             _ckvmssts(sys$dassgn(p->chan_in));
2872         } else  {
2873             _ckvmssts(iss);
2874         }
2875
2876         b->eof  = eof;
2877         b->size = p->iosb.count;
2878         _ckvmssts(sts = lib$insqhi(b, &p->wait));
2879         if (p->need_wake) {
2880             p->need_wake = FALSE;
2881             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2882         }
2883     } else {
2884         p->retry = 1;   /* initial call */
2885     }
2886
2887     if (eof) {                  /* flush the free queue, return when done */
2888         int n = sizeof(CBuf) + p->bufsize;
2889         while (1) {
2890             iss = lib$remqti(&p->free, &b);
2891             if (iss == LIB$_QUEWASEMP) return;
2892             _ckvmssts(iss);
2893             _ckvmssts(lib$free_vm(&n, &b));
2894         }
2895     }
2896
2897     iss = lib$remqti(&p->free, &b);
2898     if (iss == LIB$_QUEWASEMP) {
2899         int n = sizeof(CBuf) + p->bufsize;
2900         _ckvmssts(lib$get_vm(&n, &b));
2901         b->buf = (char *) b + sizeof(CBuf);
2902     } else {
2903        _ckvmssts(iss);
2904     }
2905
2906     p->curr = b;
2907     iss = sys$qio(0,p->chan_in,
2908              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2909              &p->iosb,
2910              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2911     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2912     _ckvmssts(iss);
2913 }
2914
2915
2916 /* writes queued buffers to output, waits for each to complete before
2917    doing the next */
2918
2919 static void
2920 pipe_tochild2_ast(pPipe p)
2921 {
2922     pCBuf b = p->curr2;
2923     int iss = p->iosb2.status;
2924     int n = sizeof(CBuf) + p->bufsize;
2925     int done = (p->info && p->info->done) ||
2926               iss == SS$_CANCEL || iss == SS$_ABORT;
2927 #if defined(PERL_IMPLICIT_CONTEXT)
2928     pTHX = p->thx;
2929 #endif
2930
2931     do {
2932         if (p->type) {         /* type=1 has old buffer, dispose */
2933             if (p->shut_on_empty) {
2934                 _ckvmssts(lib$free_vm(&n, &b));
2935             } else {
2936                 _ckvmssts(lib$insqhi(b, &p->free));
2937             }
2938             p->type = 0;
2939         }
2940
2941         iss = lib$remqti(&p->wait, &b);
2942         if (iss == LIB$_QUEWASEMP) {
2943             if (p->shut_on_empty) {
2944                 if (done) {
2945                     _ckvmssts(sys$dassgn(p->chan_out));
2946                     *p->pipe_done = TRUE;
2947                     _ckvmssts(sys$setef(pipe_ef));
2948                 } else {
2949                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2950                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2951                 }
2952                 return;
2953             }
2954             p->need_wake = TRUE;
2955             return;
2956         }
2957         _ckvmssts(iss);
2958         p->type = 1;
2959     } while (done);
2960
2961
2962     p->curr2 = b;
2963     if (b->eof) {
2964         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2965             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2966     } else {
2967         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2968             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2969     }
2970
2971     return;
2972
2973 }
2974
2975
2976 static pPipe
2977 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2978 {
2979     pPipe p;
2980     char mbx1[64], mbx2[64];
2981     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2982                                       DSC$K_CLASS_S, mbx1},
2983                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2984                                       DSC$K_CLASS_S, mbx2};
2985     unsigned int dviitm = DVI$_DEVBUFSIZ;
2986
2987     int n = sizeof(Pipe);
2988     _ckvmssts(lib$get_vm(&n, &p));
2989     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2990     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2991
2992     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2993     n = p->bufsize * sizeof(char);
2994     _ckvmssts(lib$get_vm(&n, &p->buf));
2995     p->shut_on_empty = FALSE;
2996     p->info   = 0;
2997     p->type   = 0;
2998     p->iosb.status = SS$_NORMAL;
2999 #if defined(PERL_IMPLICIT_CONTEXT)
3000     p->thx = aTHX;
3001 #endif
3002     pipe_infromchild_ast(p);
3003
3004     strcpy(wmbx, mbx1);
3005     strcpy(rmbx, mbx2);
3006     return p;
3007 }
3008
3009 static void
3010 pipe_infromchild_ast(pPipe p)
3011 {
3012     int iss = p->iosb.status;
3013     int eof = (iss == SS$_ENDOFFILE);
3014     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3015     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3016 #if defined(PERL_IMPLICIT_CONTEXT)
3017     pTHX = p->thx;
3018 #endif
3019
3020     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3021         _ckvmssts(sys$dassgn(p->chan_out));
3022         p->chan_out = 0;
3023     }
3024
3025     /* read completed:
3026             input shutdown if EOF from self (done or shut_on_empty)
3027             output shutdown if closing flag set (my_pclose)
3028             send data/eof from child or eof from self
3029             otherwise, re-read (snarf of data from child)
3030     */
3031
3032     if (p->type == 1) {
3033         p->type = 0;
3034         if (myeof && p->chan_in) {                  /* input shutdown */
3035             _ckvmssts(sys$dassgn(p->chan_in));
3036             p->chan_in = 0;
3037         }
3038
3039         if (p->chan_out) {
3040             if (myeof || kideof) {      /* pass EOF to parent */
3041                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3042                               pipe_infromchild_ast, p,
3043                               0, 0, 0, 0, 0, 0));
3044                 return;
3045             } else if (eof) {       /* eat EOF --- fall through to read*/
3046
3047             } else {                /* transmit data */
3048                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3049                               pipe_infromchild_ast,p,
3050                               p->buf, p->iosb.count, 0, 0, 0, 0));
3051                 return;
3052             }
3053         }
3054     }
3055
3056     /*  everything shut? flag as done */
3057
3058     if (!p->chan_in && !p->chan_out) {
3059         *p->pipe_done = TRUE;
3060         _ckvmssts(sys$setef(pipe_ef));
3061         return;
3062     }
3063
3064     /* write completed (or read, if snarfing from child)
3065             if still have input active,
3066                queue read...immediate mode if shut_on_empty so we get EOF if empty
3067             otherwise,
3068                check if Perl reading, generate EOFs as needed
3069     */
3070
3071     if (p->type == 0) {
3072         p->type = 1;
3073         if (p->chan_in) {
3074             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3075                           pipe_infromchild_ast,p,
3076                           p->buf, p->bufsize, 0, 0, 0, 0);
3077             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3078             _ckvmssts(iss);
3079         } else {           /* send EOFs for extra reads */
3080             p->iosb.status = SS$_ENDOFFILE;
3081             p->iosb.dvispec = 0;
3082             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3083                       0, 0, 0,
3084                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3085         }
3086     }
3087 }
3088
3089 static pPipe
3090 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3091 {
3092     pPipe p;
3093     char mbx[64];
3094     unsigned long dviitm = DVI$_DEVBUFSIZ;
3095     struct stat s;
3096     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3097                                       DSC$K_CLASS_S, mbx};
3098     int n = sizeof(Pipe);
3099
3100     /* things like terminals and mbx's don't need this filter */
3101     if (fd && fstat(fd,&s) == 0) {
3102         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3103         char device[65];
3104         unsigned short dev_len;
3105         struct dsc$descriptor_s d_dev;
3106         char * cptr;
3107         struct item_list_3 items[3];
3108         int status;
3109         unsigned short dvi_iosb[4];
3110
3111         cptr = getname(fd, out, 1);
3112         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3113         d_dev.dsc$a_pointer = out;
3114         d_dev.dsc$w_length = strlen(out);
3115         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3116         d_dev.dsc$b_class = DSC$K_CLASS_S;
3117
3118         items[0].len = 4;
3119         items[0].code = DVI$_DEVCHAR;
3120         items[0].bufadr = &devchar;
3121         items[0].retadr = NULL;
3122         items[1].len = 64;
3123         items[1].code = DVI$_FULLDEVNAM;
3124         items[1].bufadr = device;
3125         items[1].retadr = &dev_len;
3126         items[2].len = 0;
3127         items[2].code = 0;
3128
3129         status = sys$getdviw
3130                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3131         _ckvmssts(status);
3132         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3133             device[dev_len] = 0;
3134
3135             if (!(devchar & DEV$M_DIR)) {
3136                 strcpy(out, device);
3137                 return 0;
3138             }
3139         }
3140     }
3141
3142     _ckvmssts(lib$get_vm(&n, &p));
3143     p->fd_out = dup(fd);
3144     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3145     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3146     n = (p->bufsize+1) * sizeof(char);
3147     _ckvmssts(lib$get_vm(&n, &p->buf));
3148     p->shut_on_empty = FALSE;
3149     p->retry = 0;
3150     p->info  = 0;
3151     strcpy(out, mbx);
3152
3153     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3154                   pipe_mbxtofd_ast, p,
3155                   p->buf, p->bufsize, 0, 0, 0, 0));
3156
3157     return p;
3158 }
3159
3160 static void
3161 pipe_mbxtofd_ast(pPipe p)
3162 {
3163     int iss = p->iosb.status;
3164     int done = p->info->done;
3165     int iss2;
3166     int eof = (iss == SS$_ENDOFFILE);
3167     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3168     int err = !(iss&1) && !eof;
3169 #if defined(PERL_IMPLICIT_CONTEXT)
3170     pTHX = p->thx;
3171 #endif
3172
3173     if (done && myeof) {               /* end piping */
3174         close(p->fd_out);
3175         sys$dassgn(p->chan_in);
3176         *p->pipe_done = TRUE;
3177         _ckvmssts(sys$setef(pipe_ef));
3178         return;
3179     }
3180
3181     if (!err && !eof) {             /* good data to send to file */
3182         p->buf[p->iosb.count] = '\n';
3183         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3184         if (iss2 < 0) {
3185             p->retry++;
3186             if (p->retry < MAX_RETRY) {
3187                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3188                 return;
3189             }
3190         }
3191         p->retry = 0;
3192     } else if (err) {
3193         _ckvmssts(iss);
3194     }
3195
3196
3197     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3198           pipe_mbxtofd_ast, p,
3199           p->buf, p->bufsize, 0, 0, 0, 0);
3200     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3201     _ckvmssts(iss);
3202 }
3203
3204
3205 typedef struct _pipeloc     PLOC;
3206 typedef struct _pipeloc*   pPLOC;
3207
3208 struct _pipeloc {
3209     pPLOC   next;
3210     char    dir[NAM$C_MAXRSS+1];
3211 };
3212 static pPLOC  head_PLOC = 0;
3213
3214 void
3215 free_pipelocs(pTHX_ void *head)
3216 {
3217     pPLOC p, pnext;
3218     pPLOC *pHead = (pPLOC *)head;
3219
3220     p = *pHead;
3221     while (p) {
3222         pnext = p->next;
3223         PerlMem_free(p);
3224         p = pnext;
3225     }
3226     *pHead = 0;
3227 }
3228
3229 static void
3230 store_pipelocs(pTHX)
3231 {
3232     int    i;
3233     pPLOC  p;
3234     AV    *av = 0;
3235     SV    *dirsv;
3236     GV    *gv;
3237     char  *dir, *x;
3238     char  *unixdir;
3239     char  temp[NAM$C_MAXRSS+1];
3240     STRLEN n_a;
3241
3242     if (head_PLOC)
3243         free_pipelocs(aTHX_ &head_PLOC);
3244
3245 /*  the . directory from @INC comes last */
3246
3247     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3248     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3249     p->next = head_PLOC;
3250     head_PLOC = p;
3251     strcpy(p->dir,"./");
3252
3253 /*  get the directory from $^X */
3254
3255     unixdir = PerlMem_malloc(VMS_MAXRSS);
3256     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3257
3258 #ifdef PERL_IMPLICIT_CONTEXT
3259     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3260 #else
3261     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3262 #endif
3263         strcpy(temp, PL_origargv[0]);
3264         x = strrchr(temp,']');
3265         if (x == NULL) {
3266         x = strrchr(temp,'>');
3267           if (x == NULL) {
3268             /* It could be a UNIX path */
3269             x = strrchr(temp,'/');
3270           }
3271         }
3272         if (x)
3273           x[1] = '\0';
3274         else {
3275           /* Got a bare name, so use default directory */
3276           temp[0] = '.';
3277           temp[1] = '\0';
3278         }
3279
3280         if ((tounixpath(temp, unixdir)) != Nullch) {
3281             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3282             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3283             p->next = head_PLOC;
3284             head_PLOC = p;
3285             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3286             p->dir[NAM$C_MAXRSS] = '\0';
3287         }
3288     }
3289
3290 /*  reverse order of @INC entries, skip "." since entered above */
3291
3292 #ifdef PERL_IMPLICIT_CONTEXT
3293     if (aTHX)
3294 #endif
3295     if (PL_incgv) av = GvAVn(PL_incgv);
3296
3297     for (i = 0; av && i <= AvFILL(av); i++) {
3298         dirsv = *av_fetch(av,i,TRUE);
3299
3300         if (SvROK(dirsv)) continue;
3301         dir = SvPVx(dirsv,n_a);
3302         if (strcmp(dir,".") == 0) continue;
3303         if ((tounixpath(dir, unixdir)) == Nullch)
3304             continue;
3305
3306         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3307         p->next = head_PLOC;
3308         head_PLOC = p;
3309         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3310         p->dir[NAM$C_MAXRSS] = '\0';
3311     }
3312
3313 /* most likely spot (ARCHLIB) put first in the list */
3314
3315 #ifdef ARCHLIB_EXP
3316     if ((tounixpath(ARCHLIB_EXP, unixdir)) != Nullch) {
3317         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3318         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3319         p->next = head_PLOC;
3320         head_PLOC = p;
3321         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3322         p->dir[NAM$C_MAXRSS] = '\0';
3323     }
3324 #endif
3325     PerlMem_free(unixdir);
3326 }
3327
3328 static I32
3329 Perl_cando_by_name_int
3330    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3331 #if !defined(PERL_IMPLICIT_CONTEXT)
3332 #define cando_by_name_int               Perl_cando_by_name_int
3333 #else
3334 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3335 #endif
3336
3337 static char *
3338 find_vmspipe(pTHX)
3339 {
3340     static int   vmspipe_file_status = 0;
3341     static char  vmspipe_file[NAM$C_MAXRSS+1];
3342
3343     /* already found? Check and use ... need read+execute permission */
3344
3345     if (vmspipe_file_status == 1) {
3346         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3347          && cando_by_name_int
3348            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3349             return vmspipe_file;
3350         }
3351         vmspipe_file_status = 0;
3352     }
3353
3354     /* scan through stored @INC, $^X */
3355
3356     if (vmspipe_file_status == 0) {
3357         char file[NAM$C_MAXRSS+1];
3358         pPLOC  p = head_PLOC;
3359
3360         while (p) {
3361             char * exp_res;
3362             int dirlen;
3363             strcpy(file, p->dir);
3364             dirlen = strlen(file);
3365             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3366             file[NAM$C_MAXRSS] = '\0';
3367             p = p->next;
3368
3369             exp_res = do_rmsexpand
3370                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS);
3371             if (!exp_res) continue;
3372
3373             if (cando_by_name_int
3374                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3375              && cando_by_name_int
3376                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3377                 vmspipe_file_status = 1;
3378                 return vmspipe_file;
3379             }
3380         }
3381         vmspipe_file_status = -1;   /* failed, use tempfiles */
3382     }
3383
3384     return 0;
3385 }
3386
3387 static FILE *
3388 vmspipe_tempfile(pTHX)
3389 {
3390     char file[NAM$C_MAXRSS+1];
3391     FILE *fp;
3392     static int index = 0;
3393     Stat_t s0, s1;
3394     int cmp_result;
3395
3396     /* create a tempfile */
3397
3398     /* we can't go from   W, shr=get to  R, shr=get without
3399        an intermediate vulnerable state, so don't bother trying...
3400
3401        and lib$spawn doesn't shr=put, so have to close the write
3402
3403        So... match up the creation date/time and the FID to
3404        make sure we're dealing with the same file
3405
3406     */
3407
3408     index++;
3409     if (!decc_filename_unix_only) {
3410       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3411       fp = fopen(file,"w");
3412       if (!fp) {
3413         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3414         fp = fopen(file,"w");
3415         if (!fp) {
3416             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3417             fp = fopen(file,"w");
3418         }
3419       }
3420      }
3421      else {
3422       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3423       fp = fopen(file,"w");
3424       if (!fp) {
3425         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3426         fp = fopen(file,"w");
3427         if (!fp) {
3428           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3429           fp = fopen(file,"w");
3430         }
3431       }
3432     }
3433     if (!fp) return 0;  /* we're hosed */
3434
3435     fprintf(fp,"$! 'f$verify(0)'\n");
3436     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3437     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3438     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3439     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3440     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3441     fprintf(fp,"$ perl_del    = \"delete\"\n");
3442     fprintf(fp,"$ pif         = \"if\"\n");
3443     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3444     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3445     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3446     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3447     fprintf(fp,"$!  --- build command line to get max possible length\n");
3448     fprintf(fp,"$c=perl_popen_cmd0\n");
3449     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3450     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3451     fprintf(fp,"$x=perl_popen_cmd3\n");
3452     fprintf(fp,"$c=c+x\n");
3453     fprintf(fp,"$ perl_on\n");
3454     fprintf(fp,"$ 'c'\n");
3455     fprintf(fp,"$ perl_status = $STATUS\n");
3456     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3457     fprintf(fp,"$ perl_exit 'perl_status'\n");
3458     fsync(fileno(fp));
3459
3460     fgetname(fp, file, 1);
3461     fstat(fileno(fp), (struct stat *)&s0);
3462     fclose(fp);
3463
3464     if (decc_filename_unix_only)
3465         do_tounixspec(file, file, 0);
3466     fp = fopen(file,"r","shr=get");
3467     if (!fp) return 0;
3468     fstat(fileno(fp), (struct stat *)&s1);
3469
3470     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3471     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3472         fclose(fp);
3473         return 0;
3474     }
3475
3476     return fp;
3477 }
3478
3479
3480
3481 static PerlIO *
3482 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3483 {
3484     static int handler_set_up = FALSE;
3485     unsigned long int sts, flags = CLI$M_NOWAIT;
3486     /* The use of a GLOBAL table (as was done previously) rendered
3487      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3488      * environment.  Hence we've switched to LOCAL symbol table.
3489      */
3490     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3491     int j, wait = 0, n;
3492     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3493     char *in, *out, *err, mbx[512];
3494     FILE *tpipe = 0;
3495     char tfilebuf[NAM$C_MAXRSS+1];
3496     pInfo info = NULL;
3497     char cmd_sym_name[20];
3498     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3499                                       DSC$K_CLASS_S, symbol};
3500     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3501                                       DSC$K_CLASS_S, 0};
3502     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3503                                       DSC$K_CLASS_S, cmd_sym_name};
3504     struct dsc$descriptor_s *vmscmd;
3505     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3506     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3507     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3508
3509     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3510
3511     /* once-per-program initialization...
3512        note that the SETAST calls and the dual test of pipe_ef
3513        makes sure that only the FIRST thread through here does
3514        the initialization...all other threads wait until it's
3515        done.
3516
3517        Yeah, uglier than a pthread call, it's got all the stuff inline
3518        rather than in a separate routine.
3519     */
3520
3521     if (!pipe_ef) {
3522         _ckvmssts(sys$setast(0));
3523         if (!pipe_ef) {
3524             unsigned long int pidcode = JPI$_PID;
3525             $DESCRIPTOR(d_delay, RETRY_DELAY);
3526             _ckvmssts(lib$get_ef(&pipe_ef));
3527             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3528             _ckvmssts(sys$bintim(&d_delay, delaytime));
3529         }
3530         if (!handler_set_up) {
3531           _ckvmssts(sys$dclexh(&pipe_exitblock));
3532           handler_set_up = TRUE;
3533         }
3534         _ckvmssts(sys$setast(1));
3535     }
3536
3537     /* see if we can find a VMSPIPE.COM */
3538
3539     tfilebuf[0] = '@';
3540     vmspipe = find_vmspipe(aTHX);
3541     if (vmspipe) {
3542         strcpy(tfilebuf+1,vmspipe);
3543     } else {        /* uh, oh...we're in tempfile hell */
3544         tpipe = vmspipe_tempfile(aTHX);
3545         if (!tpipe) {       /* a fish popular in Boston */
3546             if (ckWARN(WARN_PIPE)) {
3547                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3548             }
3549         return Nullfp;
3550         }
3551         fgetname(tpipe,tfilebuf+1,1);
3552     }
3553     vmspipedsc.dsc$a_pointer = tfilebuf;
3554     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3555
3556     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3557     if (!(sts & 1)) {
3558       switch (sts) {
3559         case RMS$_FNF:  case RMS$_DNF:
3560           set_errno(ENOENT); break;
3561         case RMS$_DIR:
3562           set_errno(ENOTDIR); break;
3563         case RMS$_DEV:
3564           set_errno(ENODEV); break;
3565         case RMS$_PRV:
3566           set_errno(EACCES); break;
3567         case RMS$_SYN:
3568           set_errno(EINVAL); break;
3569         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3570           set_errno(E2BIG); break;
3571         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3572           _ckvmssts(sts); /* fall through */
3573         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3574           set_errno(EVMSERR);
3575       }
3576       set_vaxc_errno(sts);
3577       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3578         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3579       }
3580       *psts = sts;
3581       return Nullfp;
3582     }
3583     n = sizeof(Info);
3584     _ckvmssts(lib$get_vm(&n, &info));
3585
3586     strcpy(mode,in_mode);
3587     info->mode = *mode;
3588     info->done = FALSE;
3589     info->completion = 0;
3590     info->closing    = FALSE;
3591     info->in         = 0;
3592     info->out        = 0;
3593     info->err        = 0;
3594     info->fp         = Nullfp;
3595     info->useFILE    = 0;
3596     info->waiting    = 0;
3597     info->in_done    = TRUE;
3598     info->out_done   = TRUE;
3599     info->err_done   = TRUE;
3600
3601     in = PerlMem_malloc(VMS_MAXRSS);
3602     if (in == NULL) _ckvmssts(SS$_INSFMEM);
3603     out = PerlMem_malloc(VMS_MAXRSS);
3604     if (out == NULL) _ckvmssts(SS$_INSFMEM);
3605     err = PerlMem_malloc(VMS_MAXRSS);
3606     if (err == NULL) _ckvmssts(SS$_INSFMEM);
3607
3608     in[0] = out[0] = err[0] = '\0';
3609
3610     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3611         info->useFILE = 1;
3612         strcpy(p,p+1);
3613     }
3614     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3615         wait = 1;
3616         strcpy(p,p+1);
3617     }
3618
3619     if (*mode == 'r') {             /* piping from subroutine */
3620
3621         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3622         if (info->out) {
3623             info->out->pipe_done = &info->out_done;
3624             info->out_done = FALSE;
3625             info->out->info = info;
3626         }
3627         if (!info->useFILE) {
3628         info->fp  = PerlIO_open(mbx, mode);
3629         } else {
3630             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3631             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3632         }
3633
3634         if (!info->fp && info->out) {
3635             sys$cancel(info->out->chan_out);
3636
3637             while (!info->out_done) {
3638                 int done;
3639                 _ckvmssts(sys$setast(0));
3640                 done = info->out_done;
3641                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3642                 _ckvmssts(sys$setast(1));
3643                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3644             }
3645
3646             if (info->out->buf) {
3647                 n = info->out->bufsize * sizeof(char);
3648                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3649             }
3650             n = sizeof(Pipe);
3651             _ckvmssts(lib$free_vm(&n, &info->out));
3652             n = sizeof(Info);
3653             _ckvmssts(lib$free_vm(&n, &info));
3654             *psts = RMS$_FNF;
3655             return Nullfp;
3656         }
3657
3658         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3659         if (info->err) {
3660             info->err->pipe_done = &info->err_done;
3661             info->err_done = FALSE;
3662             info->err->info = info;
3663         }
3664
3665     } else if (*mode == 'w') {      /* piping to subroutine */
3666
3667         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3668         if (info->out) {
3669             info->out->pipe_done = &info->out_done;
3670             info->out_done = FALSE;
3671             info->out->info = info;
3672         }
3673
3674         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3675         if (info->err) {
3676             info->err->pipe_done = &info->err_done;
3677             info->err_done = FALSE;
3678             info->err->info = info;
3679         }
3680
3681         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3682         if (!info->useFILE) {
3683             info->fp  = PerlIO_open(mbx, mode);
3684         } else {
3685             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3686             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3687         }
3688
3689         if (info->in) {
3690             info->in->pipe_done = &info->in_done;
3691             info->in_done = FALSE;
3692             info->in->info = info;
3693         }
3694
3695         /* error cleanup */
3696         if (!info->fp && info->in) {
3697             info->done = TRUE;
3698             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3699                               0, 0, 0, 0, 0, 0, 0, 0));
3700
3701             while (!info->in_done) {
3702                 int done;
3703                 _ckvmssts(sys$setast(0));
3704                 done = info->in_done;
3705                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3706                 _ckvmssts(sys$setast(1));
3707                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3708             }
3709
3710             if (info->in->buf) {
3711                 n = info->in->bufsize * sizeof(char);
3712                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3713             }
3714             n = sizeof(Pipe);
3715             _ckvmssts(lib$free_vm(&n, &info->in));
3716             n = sizeof(Info);
3717             _ckvmssts(lib$free_vm(&n, &info));
3718             *psts = RMS$_FNF;
3719             return Nullfp;
3720         }
3721
3722
3723     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3724         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3725         if (info->out) {
3726             info->out->pipe_done = &info->out_done;
3727             info->out_done = FALSE;
3728             info->out->info = info;
3729         }
3730
3731         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3732         if (info->err) {
3733             info->err->pipe_done = &info->err_done;
3734             info->err_done = FALSE;
3735             info->err->info = info;
3736         }
3737     }
3738
3739     symbol[MAX_DCL_SYMBOL] = '\0';
3740
3741     strncpy(symbol, in, MAX_DCL_SYMBOL);
3742     d_symbol.dsc$w_length = strlen(symbol);
3743     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3744
3745     strncpy(symbol, err, MAX_DCL_SYMBOL);
3746     d_symbol.dsc$w_length = strlen(symbol);
3747     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3748
3749     strncpy(symbol, out, MAX_DCL_SYMBOL);
3750     d_symbol.dsc$w_length = strlen(symbol);
3751     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3752
3753     /* Done with the names for the pipes */
3754     PerlMem_free(err);
3755     PerlMem_free(out);
3756     PerlMem_free(in);
3757
3758     p = vmscmd->dsc$a_pointer;
3759     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
3760     if (*p == '$') p++;                         /* remove leading $ */
3761     while (*p == ' ' || *p == '\t') p++;
3762
3763     for (j = 0; j < 4; j++) {
3764         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3765         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3766
3767     strncpy(symbol, p, MAX_DCL_SYMBOL);
3768     d_symbol.dsc$w_length = strlen(symbol);
3769     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3770
3771         if (strlen(p) > MAX_DCL_SYMBOL) {
3772             p += MAX_DCL_SYMBOL;
3773         } else {
3774             p += strlen(p);
3775         }
3776     }
3777     _ckvmssts(sys$setast(0));
3778     info->next=open_pipes;  /* prepend to list */
3779     open_pipes=info;
3780     _ckvmssts(sys$setast(1));
3781     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3782      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
3783      * have SYS$COMMAND if we need it.
3784      */
3785     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3786                       0, &info->pid, &info->completion,
3787                       0, popen_completion_ast,info,0,0,0));
3788
3789     /* if we were using a tempfile, close it now */
3790
3791     if (tpipe) fclose(tpipe);
3792
3793     /* once the subprocess is spawned, it has copied the symbols and
3794        we can get rid of ours */
3795
3796     for (j = 0; j < 4; j++) {
3797         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3798         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3799     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3800     }
3801     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
3802     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3803     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3804     vms_execfree(vmscmd);
3805
3806 #ifdef PERL_IMPLICIT_CONTEXT
3807     if (aTHX)
3808 #endif
3809     PL_forkprocess = info->pid;
3810
3811     if (wait) {
3812          int done = 0;
3813          while (!done) {
3814              _ckvmssts(sys$setast(0));
3815              done = info->done;
3816              if (!done) _ckvmssts(sys$clref(pipe_ef));
3817              _ckvmssts(sys$setast(1));
3818              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3819          }
3820         *psts = info->completion;
3821 /* Caller thinks it is open and tries to close it. */
3822 /* This causes some problems, as it changes the error status */
3823 /*        my_pclose(info->fp); */
3824     } else {
3825         *psts = SS$_NORMAL;
3826     }
3827     return info->fp;
3828 }  /* end of safe_popen */
3829
3830
3831 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
3832 PerlIO *
3833 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3834 {
3835     int sts;
3836     TAINT_ENV();
3837     TAINT_PROPER("popen");
3838     PERL_FLUSHALL_FOR_CHILD;
3839     return safe_popen(aTHX_ cmd,mode,&sts);
3840 }
3841
3842 /*}}}*/
3843
3844 /*{{{  I32 my_pclose(PerlIO *fp)*/
3845 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3846 {
3847     pInfo info, last = NULL;
3848     unsigned long int retsts;
3849     int done, iss, n;
3850
3851     for (info = open_pipes; info != NULL; last = info, info = info->next)
3852         if (info->fp == fp) break;
3853
3854     if (info == NULL) {  /* no such pipe open */
3855       set_errno(ECHILD); /* quoth POSIX */
3856       set_vaxc_errno(SS$_NONEXPR);
3857       return -1;
3858     }
3859
3860     /* If we were writing to a subprocess, insure that someone reading from
3861      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
3862      * produce an EOF record in the mailbox.
3863      *
3864      *  well, at least sometimes it *does*, so we have to watch out for
3865      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
3866      */
3867      if (info->fp) {
3868         if (!info->useFILE)
3869             PerlIO_flush(info->fp);   /* first, flush data */
3870         else
3871             fflush((FILE *)info->fp);
3872     }
3873
3874     _ckvmssts(sys$setast(0));
3875      info->closing = TRUE;
3876      done = info->done && info->in_done && info->out_done && info->err_done;
3877      /* hanging on write to Perl's input? cancel it */
3878      if (info->mode == 'r' && info->out && !info->out_done) {
3879         if (info->out->chan_out) {
3880             _ckvmssts(sys$cancel(info->out->chan_out));
3881             if (!info->out->chan_in) {   /* EOF generation, need AST */
3882                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3883             }
3884         }
3885      }
3886      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
3887          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3888                            0, 0, 0, 0, 0, 0));
3889     _ckvmssts(sys$setast(1));
3890     if (info->fp) {
3891      if (!info->useFILE)
3892         PerlIO_close(info->fp);
3893      else
3894         fclose((FILE *)info->fp);
3895     }
3896      /*
3897         we have to wait until subprocess completes, but ALSO wait until all
3898         the i/o completes...otherwise we'll be freeing the "info" structure
3899         that the i/o ASTs could still be using...
3900      */
3901
3902      while (!done) {
3903          _ckvmssts(sys$setast(0));
3904          done = info->done && info->in_done && info->out_done && info->err_done;
3905          if (!done) _ckvmssts(sys$clref(pipe_ef));
3906          _ckvmssts(sys$setast(1));
3907          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3908      }
3909      retsts = info->completion;
3910
3911     /* remove from list of open pipes */
3912     _ckvmssts(sys$setast(0));
3913     if (last) last->next = info->next;
3914     else open_pipes = info->next;
3915     _ckvmssts(sys$setast(1));
3916
3917     /* free buffers and structures */
3918
3919     if (info->in) {
3920         if (info->in->buf) {
3921             n = info->in->bufsize * sizeof(char);
3922             _ckvmssts(lib$free_vm(&n, &info->in->buf));
3923         }
3924         n = sizeof(Pipe);
3925         _ckvmssts(lib$free_vm(&n, &info->in));
3926     }
3927     if (info->out) {
3928         if (info->out->buf) {
3929             n = info->out->bufsize * sizeof(char);
3930             _ckvmssts(lib$free_vm(&n, &info->out->buf));
3931         }
3932         n = sizeof(Pipe);
3933         _ckvmssts(lib$free_vm(&n, &info->out));
3934     }
3935     if (info->err) {
3936         if (info->err->buf) {
3937             n = info->err->bufsize * sizeof(char);
3938             _ckvmssts(lib$free_vm(&n, &info->err->buf));
3939         }
3940         n = sizeof(Pipe);
3941         _ckvmssts(lib$free_vm(&n, &info->err));
3942     }
3943     n = sizeof(Info);
3944     _ckvmssts(lib$free_vm(&n, &info));
3945
3946     return retsts;
3947
3948 }  /* end of my_pclose() */
3949
3950 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3951   /* Roll our own prototype because we want this regardless of whether
3952    * _VMS_WAIT is defined.
3953    */
3954   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3955 #endif
3956 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3957    created with popen(); otherwise partially emulate waitpid() unless
3958    we have a suitable one from the CRTL that came with VMS 7.2 and later.
3959    Also check processes not considered by the CRTL waitpid().
3960  */
3961 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3962 Pid_t
3963 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3964 {
3965     pInfo info;
3966     int done;
3967     int sts;
3968     int j;
3969
3970     if (statusp) *statusp = 0;
3971
3972     for (info = open_pipes; info != NULL; info = info->next)
3973         if (info->pid == pid) break;
3974
3975     if (info != NULL) {  /* we know about this child */
3976       while (!info->done) {
3977           _ckvmssts(sys$setast(0));
3978           done = info->done;
3979           if (!done) _ckvmssts(sys$clref(pipe_ef));
3980           _ckvmssts(sys$setast(1));
3981           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3982       }
3983
3984       if (statusp) *statusp = info->completion;
3985       return pid;
3986     }
3987
3988     /* child that already terminated? */
3989
3990     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3991         if (closed_list[j].pid == pid) {
3992             if (statusp) *statusp = closed_list[j].completion;
3993             return pid;
3994         }
3995     }
3996
3997     /* fall through if this child is not one of our own pipe children */
3998
3999 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4000
4001       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4002        * in 7.2 did we get a version that fills in the VMS completion
4003        * status as Perl has always tried to do.
4004        */
4005
4006       sts = __vms_waitpid( pid, statusp, flags );
4007
4008       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4009          return sts;
4010
4011       /* If the real waitpid tells us the child does not exist, we
4012        * fall through here to implement waiting for a child that
4013        * was created by some means other than exec() (say, spawned
4014        * from DCL) or to wait for a process that is not a subprocess
4015        * of the current process.
4016        */
4017
4018 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4019
4020     {
4021       $DESCRIPTOR(intdsc,"0 00:00:01");
4022       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4023       unsigned long int pidcode = JPI$_PID, mypid;
4024       unsigned long int interval[2];
4025       unsigned int jpi_iosb[2];
4026       struct itmlst_3 jpilist[2] = {
4027           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4028           {                      0,         0,                 0, 0}
4029       };
4030
4031       if (pid <= 0) {
4032         /* Sorry folks, we don't presently implement rooting around for
4033            the first child we can find, and we definitely don't want to
4034            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4035          */
4036         set_errno(ENOTSUP);
4037         return -1;
4038       }
4039
4040       /* Get the owner of the child so I can warn if it's not mine. If the
4041        * process doesn't exist or I don't have the privs to look at it,
4042        * I can go home early.
4043        */
4044       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4045       if (sts & 1) sts = jpi_iosb[0];
4046       if (!(sts & 1)) {
4047         switch (sts) {
4048             case SS$_NONEXPR:
4049                 set_errno(ECHILD);
4050                 break;
4051             case SS$_NOPRIV:
4052                 set_errno(EACCES);
4053                 break;
4054             default:
4055                 _ckvmssts(sts);
4056         }
4057         set_vaxc_errno(sts);
4058         return -1;
4059       }
4060
4061       if (ckWARN(WARN_EXEC)) {
4062         /* remind folks they are asking for non-standard waitpid behavior */
4063         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4064         if (ownerpid != mypid)
4065           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4066                       "waitpid: process %x is not a child of process %x",
4067                       pid,mypid);
4068       }
4069
4070       /* simply check on it once a second until it's not there anymore. */
4071
4072       _ckvmssts(sys$bintim(&intdsc,interval));
4073       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4074             _ckvmssts(sys$schdwk(0,0,interval,0));
4075             _ckvmssts(sys$hiber());
4076       }
4077       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4078
4079       _ckvmssts(sts);
4080       return pid;
4081     }
4082 }  /* end of waitpid() */
4083 /*}}}*/
4084 /*}}}*/
4085 /*}}}*/
4086
4087 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4088 char *
4089 my_gconvert(double val, int ndig, int trail, char *buf)
4090 {
4091   static char __gcvtbuf[DBL_DIG+1];
4092   char *loc;
4093
4094   loc = buf ? buf : __gcvtbuf;
4095
4096 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4097   if (val < 1) {
4098     sprintf(loc,"%.*g",ndig,val);
4099     return loc;
4100   }
4101 #endif
4102
4103   if (val) {
4104     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4105     return gcvt(val,ndig,loc);
4106   }
4107   else {
4108     loc[0] = '0'; loc[1] = '\0';
4109     return loc;
4110   }
4111
4112 }
4113 /*}}}*/
4114
4115 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4116 static int rms_free_search_context(struct FAB * fab)
4117 {
4118 struct NAM * nam;
4119
4120     nam = fab->fab$l_nam;
4121     nam->nam$b_nop |= NAM$M_SYNCHK;
4122     nam->nam$l_rlf = NULL;
4123     fab->fab$b_dns = 0;
4124     return sys$parse(fab, NULL, NULL);
4125 }
4126
4127 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4128 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4129 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4130 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4131 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4132 #define rms_nam_esll(nam) nam.nam$b_esl
4133 #define rms_nam_esl(nam) nam.nam$b_esl
4134 #define rms_nam_name(nam) nam.nam$l_name
4135 #define rms_nam_namel(nam) nam.nam$l_name
4136 #define rms_nam_type(nam) nam.nam$l_type
4137 #define rms_nam_typel(nam) nam.nam$l_type
4138 #define rms_nam_ver(nam) nam.nam$l_ver
4139 #define rms_nam_verl(nam) nam.nam$l_ver
4140 #define rms_nam_rsll(nam) nam.nam$b_rsl
4141 #define rms_nam_rsl(nam) nam.nam$b_rsl
4142 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4143 #define rms_set_fna(fab, nam, name, size) \
4144         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4145 #define rms_get_fna(fab, nam) fab.fab$l_fna
4146 #define rms_set_dna(fab, nam, name, size) \
4147         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4148 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4149 #define rms_set_esa(fab, nam, name, size) \
4150         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4151 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4152         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4153 #define rms_set_rsa(nam, name, size) \
4154         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4155 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4156         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4157 #define rms_nam_name_type_l_size(nam) \
4158         (nam.nam$b_name + nam.nam$b_type)
4159 #else
4160 static int rms_free_search_context(struct FAB * fab)
4161 {
4162 struct NAML * nam;
4163
4164     nam = fab->fab$l_naml;
4165     nam->naml$b_nop |= NAM$M_SYNCHK;
4166     nam->naml$l_rlf = NULL;
4167     nam->naml$l_long_defname_size = 0;
4168
4169     fab->fab$b_dns = 0;
4170     return sys$parse(fab, NULL, NULL);
4171 }
4172
4173 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4174 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4175 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4176 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4177 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4178 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4179 #define rms_nam_esl(nam) nam.naml$b_esl
4180 #define rms_nam_name(nam) nam.naml$l_name
4181 #define rms_nam_namel(nam) nam.naml$l_long_name
4182 #define rms_nam_type(nam) nam.naml$l_type
4183 #define rms_nam_typel(nam) nam.naml$l_long_type
4184 #define rms_nam_ver(nam) nam.naml$l_ver
4185 #define rms_nam_verl(nam) nam.naml$l_long_ver
4186 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4187 #define rms_nam_rsl(nam) nam.naml$b_rsl
4188 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4189 #define rms_set_fna(fab, nam, name, size) \
4190         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4191         nam.naml$l_long_filename_size = size; \
4192         nam.naml$l_long_filename = name;}
4193 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4194 #define rms_set_dna(fab, nam, name, size) \
4195         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4196         nam.naml$l_long_defname_size = size; \
4197         nam.naml$l_long_defname = name; }
4198 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4199 #define rms_set_esa(fab, nam, name, size) \
4200         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4201         nam.naml$l_long_expand_alloc = size; \
4202         nam.naml$l_long_expand = name; }
4203 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4204         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4205         nam.naml$l_long_expand = l_name; \
4206         nam.naml$l_long_expand_alloc = l_size; }
4207 #define rms_set_rsa(nam, name, size) \
4208         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4209         nam.naml$l_long_result = name; \
4210         nam.naml$l_long_result_alloc = size; }
4211 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4212         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4213         nam.naml$l_long_result = l_name; \
4214         nam.naml$l_long_result_alloc = l_size; }
4215 #define rms_nam_name_type_l_size(nam) \
4216         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4217 #endif
4218
4219
4220 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4221 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4222  * to expand file specification.  Allows for a single default file
4223  * specification and a simple mask of options.  If outbuf is non-NULL,
4224  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4225  * the resultant file specification is placed.  If outbuf is NULL, the
4226  * resultant file specification is placed into a static buffer.
4227  * The third argument, if non-NULL, is taken to be a default file
4228  * specification string.  The fourth argument is unused at present.
4229  * rmesexpand() returns the address of the resultant string if
4230  * successful, and NULL on error.
4231  *
4232  * New functionality for previously unused opts value:
4233  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4234  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
4235  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4236  */
4237 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
4238
4239 static char *
4240 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4241 {
4242   static char __rmsexpand_retbuf[VMS_MAXRSS];
4243   char * vmsfspec, *tmpfspec;
4244   char * esa, *cp, *out = NULL;
4245   char * tbuf;
4246   char * esal;
4247   char * outbufl;
4248   struct FAB myfab = cc$rms_fab;
4249   rms_setup_nam(mynam);
4250   STRLEN speclen;
4251   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4252   int sts;
4253
4254   if (!filespec || !*filespec) {
4255     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4256     return NULL;
4257   }
4258   if (!outbuf) {
4259     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4260     else    outbuf = __rmsexpand_retbuf;
4261   }
4262
4263   vmsfspec = NULL;
4264   tmpfspec = NULL;
4265   outbufl = NULL;
4266
4267   isunix = 0;
4268   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4269     isunix = is_unix_filespec(filespec);
4270     if (isunix) {
4271       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4272       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4273       if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4274         PerlMem_free(vmsfspec);
4275         if (out)
4276            Safefree(out);
4277         return NULL;
4278       }
4279       filespec = vmsfspec;
4280
4281       /* Unless we are forcing to VMS format, a UNIX input means
4282        * UNIX output, and that requires long names to be used
4283        */
4284       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4285         opts |= PERL_RMSEXPAND_M_LONG;
4286       else {
4287         isunix = 0;
4288       }
4289     }
4290   }
4291
4292   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4293   rms_bind_fab_nam(myfab, mynam);
4294
4295   if (defspec && *defspec) {
4296     int t_isunix;
4297     t_isunix = is_unix_filespec(defspec);
4298     if (t_isunix) {
4299       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4300       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4301       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4302         PerlMem_free(tmpfspec);
4303         if (vmsfspec != NULL)
4304             PerlMem_free(vmsfspec);
4305         if (out)
4306            Safefree(out);
4307         return NULL;
4308       }
4309       defspec = tmpfspec;
4310     }
4311     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4312   }
4313
4314   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4315   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4316 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4317   esal = PerlMem_malloc(VMS_MAXRSS);
4318   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4319 #endif
4320   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4321
4322   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4323     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4324   }
4325   else {
4326 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4327     outbufl = PerlMem_malloc(VMS_MAXRSS);
4328     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4329     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4330 #else
4331     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4332 #endif
4333   }
4334
4335 #ifdef NAM$M_NO_SHORT_UPCASE
4336   if (decc_efs_case_preserve)
4337     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4338 #endif
4339
4340   /* First attempt to parse as an existing file */
4341   retsts = sys$parse(&myfab,0,0);
4342   if (!(retsts & STS$K_SUCCESS)) {
4343
4344     /* Could not find the file, try as syntax only if error is not fatal */
4345     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4346     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4347       retsts = sys$parse(&myfab,0,0);
4348       if (retsts & STS$K_SUCCESS) goto expanded;
4349     }
4350
4351      /* Still could not parse the file specification */
4352     /*----------------------------------------------*/
4353     sts = rms_free_search_context(&myfab); /* Free search context */
4354     if (out) Safefree(out);
4355     if (tmpfspec != NULL)
4356         PerlMem_free(tmpfspec);
4357     if (vmsfspec != NULL)
4358         PerlMem_free(vmsfspec);
4359     if (outbufl != NULL)
4360         PerlMem_free(outbufl);
4361     PerlMem_free(esa);
4362     PerlMem_free(esal);
4363     set_vaxc_errno(retsts);
4364     if      (retsts == RMS$_PRV) set_errno(EACCES);
4365     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4366     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4367     else                         set_errno(EVMSERR);
4368     return NULL;
4369   }
4370   retsts = sys$search(&myfab,0,0);
4371   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4372     sts = rms_free_search_context(&myfab); /* Free search context */
4373     if (out) Safefree(out);
4374     if (tmpfspec != NULL)
4375         PerlMem_free(tmpfspec);
4376     if (vmsfspec != NULL)
4377         PerlMem_free(vmsfspec);
4378     if (outbufl != NULL)
4379         PerlMem_free(outbufl);
4380     PerlMem_free(esa);
4381     PerlMem_free(esal);
4382     set_vaxc_errno(retsts);
4383     if      (retsts == RMS$_PRV) set_errno(EACCES);
4384     else                         set_errno(EVMSERR);
4385     return NULL;
4386   }
4387
4388   /* If the input filespec contained any lowercase characters,
4389    * downcase the result for compatibility with Unix-minded code. */
4390   expanded:
4391   if (!decc_efs_case_preserve) {
4392     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4393       if (islower(*tbuf)) { haslower = 1; break; }
4394   }
4395
4396    /* Is a long or a short name expected */
4397   /*------------------------------------*/
4398   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4399     if (rms_nam_rsll(mynam)) {
4400         tbuf = outbuf;
4401         speclen = rms_nam_rsll(mynam);
4402     }
4403     else {
4404         tbuf = esal; /* Not esa */
4405         speclen = rms_nam_esll(mynam);
4406     }
4407   }
4408   else {
4409     if (rms_nam_rsl(mynam)) {
4410         tbuf = outbuf;
4411         speclen = rms_nam_rsl(mynam);
4412     }
4413     else {
4414         tbuf = esa; /* Not esal */
4415         speclen = rms_nam_esl(mynam);
4416     }
4417   }
4418   tbuf[speclen] = '\0';
4419
4420   /* Trim off null fields added by $PARSE
4421    * If type > 1 char, must have been specified in original or default spec
4422    * (not true for version; $SEARCH may have added version of existing file).
4423    */
4424   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4425   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4426     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4427              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4428   }
4429   else {
4430     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4431              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4432   }
4433   if (trimver || trimtype) {
4434     if (defspec && *defspec) {
4435       char *defesal = NULL;
4436       defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4437       if (defesal != NULL) {
4438         struct FAB deffab = cc$rms_fab;
4439         rms_setup_nam(defnam);
4440
4441         rms_bind_fab_nam(deffab, defnam);
4442
4443         /* Cast ok */
4444         rms_set_fna
4445             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4446
4447         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4448
4449         rms_clear_nam_nop(defnam);
4450         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4451 #ifdef NAM$M_NO_SHORT_UPCASE
4452         if (decc_efs_case_preserve)
4453           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4454 #endif
4455         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4456           if (trimver) {
4457              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4458           }
4459           if (trimtype) {
4460             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4461           }
4462         }
4463         PerlMem_free(defesal);
4464       }
4465     }
4466     if (trimver) {
4467       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4468         if (*(rms_nam_verl(mynam)) != '\"')
4469           speclen = rms_nam_verl(mynam) - tbuf;
4470       }
4471       else {
4472         if (*(rms_nam_ver(mynam)) != '\"')
4473           speclen = rms_nam_ver(mynam) - tbuf;
4474       }
4475     }
4476     if (trimtype) {
4477       /* If we didn't already trim version, copy down */
4478       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4479         if (speclen > rms_nam_verl(mynam) - tbuf)
4480           memmove
4481            (rms_nam_typel(mynam),
4482             rms_nam_verl(mynam),
4483             speclen - (rms_nam_verl(mynam) - tbuf));
4484           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4485       }
4486       else {
4487         if (speclen > rms_nam_ver(mynam) - tbuf)
4488           memmove
4489            (rms_nam_type(mynam),
4490             rms_nam_ver(mynam),
4491             speclen - (rms_nam_ver(mynam) - tbuf));
4492           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4493       }
4494     }
4495   }
4496
4497    /* Done with these copies of the input files */
4498   /*-------------------------------------------*/
4499   if (vmsfspec != NULL)
4500         PerlMem_free(vmsfspec);
4501   if (tmpfspec != NULL)
4502         PerlMem_free(tmpfspec);
4503
4504   /* If we just had a directory spec on input, $PARSE "helpfully"
4505    * adds an empty name and type for us */
4506   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4507     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4508         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
4509         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4510       speclen = rms_nam_namel(mynam) - tbuf;
4511   }
4512   else {
4513     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4514         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
4515         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4516       speclen = rms_nam_name(mynam) - tbuf;
4517   }
4518
4519   /* Posix format specifications must have matching quotes */
4520   if (speclen < (VMS_MAXRSS - 1)) {
4521     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4522       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4523         tbuf[speclen] = '\"';
4524         speclen++;
4525       }
4526     }
4527   }
4528   tbuf[speclen] = '\0';
4529   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4530
4531   /* Have we been working with an expanded, but not resultant, spec? */
4532   /* Also, convert back to Unix syntax if necessary. */
4533
4534   if (!rms_nam_rsll(mynam)) {
4535     if (isunix) {
4536       if (do_tounixspec(esa,outbuf,0) == NULL) {
4537         if (out) Safefree(out);
4538         PerlMem_free(esal);
4539         PerlMem_free(esa);
4540         if (outbufl != NULL)
4541             PerlMem_free(outbufl);
4542         return NULL;
4543       }
4544     }
4545     else strcpy(outbuf,esa);
4546   }
4547   else if (isunix) {
4548     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4549     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4550     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4551         if (out) Safefree(out);
4552         PerlMem_free(esa);
4553         PerlMem_free(esal);
4554         PerlMem_free(tmpfspec);
4555         if (outbufl != NULL)
4556             PerlMem_free(outbufl);
4557         return NULL;
4558     }
4559     strcpy(outbuf,tmpfspec);
4560     PerlMem_free(tmpfspec);
4561   }
4562
4563   rms_set_rsal(mynam, NULL, 0, NULL, 0);
4564   sts = rms_free_search_context(&myfab); /* Free search context */
4565   PerlMem_free(esa);
4566   PerlMem_free(esal);
4567   if (outbufl != NULL)
4568      PerlMem_free(outbufl);
4569   return outbuf;
4570 }
4571 /*}}}*/
4572 /* External entry points */
4573 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4574 { return do_rmsexpand(spec,buf,0,def,opt); }
4575 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4576 { return do_rmsexpand(spec,buf,1,def,opt); }
4577
4578
4579 /*
4580 ** The following routines are provided to make life easier when
4581 ** converting among VMS-style and Unix-style directory specifications.
4582 ** All will take input specifications in either VMS or Unix syntax. On
4583 ** failure, all return NULL.  If successful, the routines listed below
4584 ** return a pointer to a buffer containing the appropriately
4585 ** reformatted spec (and, therefore, subsequent calls to that routine
4586 ** will clobber the result), while the routines of the same names with
4587 ** a _ts suffix appended will return a pointer to a mallocd string
4588 ** containing the appropriately reformatted spec.
4589 ** In all cases, only explicit syntax is altered; no check is made that
4590 ** the resulting string is valid or that the directory in question
4591 ** actually exists.
4592 **
4593 **   fileify_dirspec() - convert a directory spec into the name of the
4594 **     directory file (i.e. what you can stat() to see if it's a dir).
4595 **     The style (VMS or Unix) of the result is the same as the style
4596 **     of the parameter passed in.
4597 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4598 **     what you prepend to a filename to indicate what directory it's in).
4599 **     The style (VMS or Unix) of the result is the same as the style
4600 **     of the parameter passed in.
4601 **   tounixpath() - convert a directory spec into a Unix-style path.
4602 **   tovmspath() - convert a directory spec into a VMS-style path.
4603 **   tounixspec() - convert any file spec into a Unix-style file spec.
4604 **   tovmsspec() - convert any file spec into a VMS-style spec.
4605 **
4606 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4607 ** Permission is given to distribute this code as part of the Perl
4608 ** standard distribution under the terms of the GNU General Public
4609 ** License or the Perl Artistic License.  Copies of each may be
4610 ** found in the Perl standard distribution.
4611  */
4612
4613 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4614 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4615 {
4616     static char __fileify_retbuf[VMS_MAXRSS];
4617     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4618     char *retspec, *cp1, *cp2, *lastdir;
4619     char *trndir, *vmsdir;
4620     unsigned short int trnlnm_iter_count;
4621     int sts;
4622
4623     if (!dir || !*dir) {
4624       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4625     }
4626     dirlen = strlen(dir);
4627     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4628     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4629       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4630         dir = "/sys$disk";
4631         dirlen = 9;
4632       }
4633       else
4634         dirlen = 1;
4635     }
4636     if (dirlen > (VMS_MAXRSS - 1)) {
4637       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4638       return NULL;
4639     }
4640     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4641     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4642     if (!strpbrk(dir+1,"/]>:")  &&
4643         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4644       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4645       trnlnm_iter_count = 0;
4646       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4647         trnlnm_iter_count++;
4648         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4649       }
4650       dirlen = strlen(trndir);
4651     }
4652     else {
4653       strncpy(trndir,dir,dirlen);
4654       trndir[dirlen] = '\0';
4655     }
4656
4657     /* At this point we are done with *dir and use *trndir which is a
4658      * copy that can be modified.  *dir must not be modified.
4659      */
4660
4661     /* If we were handed a rooted logical name or spec, treat it like a
4662      * simple directory, so that
4663      *    $ Define myroot dev:[dir.]
4664      *    ... do_fileify_dirspec("myroot",buf,1) ...
4665      * does something useful.
4666      */
4667     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4668       trndir[--dirlen] = '\0';
4669       trndir[dirlen-1] = ']';
4670     }
4671     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4672       trndir[--dirlen] = '\0';
4673       trndir[dirlen-1] = '>';
4674     }
4675
4676     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4677       /* If we've got an explicit filename, we can just shuffle the string. */
4678       if (*(cp1+1)) hasfilename = 1;
4679       /* Similarly, we can just back up a level if we've got multiple levels
4680          of explicit directories in a VMS spec which ends with directories. */
4681       else {
4682         for (cp2 = cp1; cp2 > trndir; cp2--) {
4683           if (*cp2 == '.') {
4684             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4685 /* fix-me, can not scan EFS file specs backward like this */
4686               *cp2 = *cp1; *cp1 = '\0';
4687               hasfilename = 1;
4688               break;
4689             }
4690           }
4691           if (*cp2 == '[' || *cp2 == '<') break;
4692         }
4693       }
4694     }
4695
4696     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4697     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4698     cp1 = strpbrk(trndir,"]:>");
4699     if (hasfilename || !cp1) { /* Unix-style path or filename */
4700       if (trndir[0] == '.') {
4701         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4702           PerlMem_free(trndir);
4703           PerlMem_free(vmsdir);
4704           return do_fileify_dirspec("[]",buf,ts);
4705         }
4706         else if (trndir[1] == '.' &&
4707                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4708           PerlMem_free(trndir);
4709           PerlMem_free(vmsdir);
4710           return do_fileify_dirspec("[-]",buf,ts);
4711         }
4712       }
4713       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4714         dirlen -= 1;                 /* to last element */
4715         lastdir = strrchr(trndir,'/');
4716       }
4717       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4718         /* If we have "/." or "/..", VMSify it and let the VMS code
4719          * below expand it, rather than repeating the code to handle
4720          * relative components of a filespec here */
4721         do {
4722           if (*(cp1+2) == '.') cp1++;
4723           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4724             char * ret_chr;
4725             if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4726                 PerlMem_free(trndir);
4727                 PerlMem_free(vmsdir);
4728                 return NULL;
4729             }
4730             if (strchr(vmsdir,'/') != NULL) {
4731               /* If do_tovmsspec() returned it, it must have VMS syntax
4732                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
4733                * the time to check this here only so we avoid a recursion
4734                * loop; otherwise, gigo.
4735                */
4736               PerlMem_free(trndir);
4737               PerlMem_free(vmsdir);
4738               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
4739               return NULL;
4740             }
4741             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4742                 PerlMem_free(trndir);
4743                 PerlMem_free(vmsdir);
4744                 return NULL;
4745             }
4746             ret_chr = do_tounixspec(trndir,buf,ts);
4747             PerlMem_free(trndir);
4748             PerlMem_free(vmsdir);
4749             return ret_chr;
4750           }
4751           cp1++;
4752         } while ((cp1 = strstr(cp1,"/.")) != NULL);
4753         lastdir = strrchr(trndir,'/');
4754       }
4755       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4756         char * ret_chr;
4757         /* Ditto for specs that end in an MFD -- let the VMS code
4758          * figure out whether it's a real device or a rooted logical. */
4759
4760         /* This should not happen any more.  Allowing the fake /000000
4761          * in a UNIX pathname causes all sorts of problems when trying
4762          * to run in UNIX emulation.  So the VMS to UNIX conversions
4763          * now remove the fake /000000 directories.
4764          */
4765
4766         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4767         if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4768             PerlMem_free(trndir);
4769             PerlMem_free(vmsdir);
4770             return NULL;
4771         }
4772         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4773             PerlMem_free(trndir);
4774             PerlMem_free(vmsdir);
4775             return NULL;
4776         }
4777         ret_chr = do_tounixspec(trndir,buf,ts);
4778         PerlMem_free(trndir);
4779         PerlMem_free(vmsdir);
4780         return ret_chr;
4781       }
4782       else {
4783
4784         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4785              !(lastdir = cp1 = strrchr(trndir,']')) &&
4786              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4787         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
4788           int ver; char *cp3;
4789
4790           /* For EFS or ODS-5 look for the last dot */
4791           if (decc_efs_charset) {
4792               cp2 = strrchr(cp1,'.');
4793           }
4794           if (vms_process_case_tolerant) {
4795               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4796                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4797                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4798                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4799                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4800                             (ver || *cp3)))))) {
4801                   PerlMem_free(trndir);
4802                   PerlMem_free(vmsdir);
4803                   set_errno(ENOTDIR);
4804                   set_vaxc_errno(RMS$_DIR);
4805                   return NULL;
4806               }
4807           }
4808           else {
4809               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4810                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4811                   !*(cp2+3) || *(cp2+3) != 'R' ||
4812                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4813                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4814                             (ver || *cp3)))))) {
4815                  PerlMem_free(trndir);
4816                  PerlMem_free(vmsdir);
4817                  set_errno(ENOTDIR);
4818                  set_vaxc_errno(RMS$_DIR);
4819                  return NULL;
4820               }
4821           }
4822           dirlen = cp2 - trndir;
4823         }
4824       }
4825
4826       retlen = dirlen + 6;
4827       if (buf) retspec = buf;
4828       else if (ts) Newx(retspec,retlen+1,char);
4829       else retspec = __fileify_retbuf;
4830       memcpy(retspec,trndir,dirlen);
4831       retspec[dirlen] = '\0';
4832
4833       /* We've picked up everything up to the directory file name.
4834          Now just add the type and version, and we're set. */
4835       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4836         strcat(retspec,".dir;1");
4837       else
4838         strcat(retspec,".DIR;1");
4839       PerlMem_free(trndir);
4840       PerlMem_free(vmsdir);
4841       return retspec;
4842     }
4843     else {  /* VMS-style directory spec */
4844
4845       char *esa, term, *cp;
4846       unsigned long int sts, cmplen, haslower = 0;
4847       unsigned int nam_fnb;
4848       char * nam_type;
4849       struct FAB dirfab = cc$rms_fab;
4850       rms_setup_nam(savnam);
4851       rms_setup_nam(dirnam);
4852
4853       esa = PerlMem_malloc(VMS_MAXRSS + 1);
4854       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4855       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4856       rms_bind_fab_nam(dirfab, dirnam);
4857       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4858       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4859 #ifdef NAM$M_NO_SHORT_UPCASE
4860       if (decc_efs_case_preserve)
4861         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4862 #endif
4863
4864       for (cp = trndir; *cp; cp++)
4865         if (islower(*cp)) { haslower = 1; break; }
4866       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4867         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4868           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4869           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4870         }
4871         if (!sts) {
4872           PerlMem_free(esa);
4873           PerlMem_free(trndir);
4874           PerlMem_free(vmsdir);
4875           set_errno(EVMSERR);
4876           set_vaxc_errno(dirfab.fab$l_sts);
4877           return NULL;
4878         }
4879       }
4880       else {
4881         savnam = dirnam;
4882         /* Does the file really exist? */
4883         if (sys$search(&dirfab)& STS$K_SUCCESS) {
4884           /* Yes; fake the fnb bits so we'll check type below */
4885         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4886         }
4887         else { /* No; just work with potential name */
4888           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4889           else {
4890             int fab_sts;
4891             fab_sts = dirfab.fab$l_sts;
4892             sts = rms_free_search_context(&dirfab);
4893             PerlMem_free(esa);
4894             PerlMem_free(trndir);
4895             PerlMem_free(vmsdir);
4896             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
4897             return NULL;
4898           }
4899         }
4900       }
4901       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4902         cp1 = strchr(esa,']');
4903         if (!cp1) cp1 = strchr(esa,'>');
4904         if (cp1) {  /* Should always be true */
4905           rms_nam_esll(dirnam) -= cp1 - esa - 1;
4906           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
4907         }
4908       }
4909       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
4910         /* Yep; check version while we're at it, if it's there. */
4911         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
4912         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
4913           /* Something other than .DIR[;1].  Bzzt. */
4914           sts = rms_free_search_context(&dirfab);
4915           PerlMem_free(esa);
4916           PerlMem_free(trndir);
4917           PerlMem_free(vmsdir);
4918           set_errno(ENOTDIR);
4919           set_vaxc_errno(RMS$_DIR);
4920           return NULL;
4921         }
4922       }
4923       esa[rms_nam_esll(dirnam)] = '\0';
4924       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
4925         /* They provided at least the name; we added the type, if necessary, */
4926         if (buf) retspec = buf;                            /* in sys$parse() */
4927         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
4928         else retspec = __fileify_retbuf;
4929         strcpy(retspec,esa);
4930         sts = rms_free_search_context(&dirfab);
4931         PerlMem_free(trndir);
4932         PerlMem_free(esa);
4933         PerlMem_free(vmsdir);
4934         return retspec;
4935       }
4936       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4937         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4938         *cp1 = '\0';
4939         rms_nam_esll(dirnam) -= 9;
4940       }
4941       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4942       if (cp1 == NULL) { /* should never happen */
4943         sts = rms_free_search_context(&dirfab);
4944         PerlMem_free(trndir);
4945         PerlMem_free(esa);
4946         PerlMem_free(vmsdir);
4947         return NULL;
4948       }
4949       term = *cp1;
4950       *cp1 = '\0';
4951       retlen = strlen(esa);
4952       cp1 = strrchr(esa,'.');
4953       /* ODS-5 directory specifications can have extra "." in them. */
4954       /* Fix-me, can not scan EFS file specifications backwards */
4955       while (cp1 != NULL) {
4956         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4957           break;
4958         else {
4959            cp1--;
4960            while ((cp1 > esa) && (*cp1 != '.'))
4961              cp1--;
4962         }
4963         if (cp1 == esa)
4964           cp1 = NULL;
4965       }
4966
4967       if ((cp1) != NULL) {
4968         /* There's more than one directory in the path.  Just roll back. */
4969         *cp1 = term;
4970         if (buf) retspec = buf;
4971         else if (ts) Newx(retspec,retlen+7,char);
4972         else retspec = __fileify_retbuf;
4973         strcpy(retspec,esa);
4974       }
4975       else {
4976         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
4977           /* Go back and expand rooted logical name */
4978           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
4979 #ifdef NAM$M_NO_SHORT_UPCASE
4980           if (decc_efs_case_preserve)
4981             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4982 #endif
4983           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
4984             sts = rms_free_search_context(&dirfab);
4985             PerlMem_free(esa);
4986             PerlMem_free(trndir);
4987             PerlMem_free(vmsdir);
4988             set_errno(EVMSERR);
4989             set_vaxc_errno(dirfab.fab$l_sts);
4990             return NULL;
4991           }
4992           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
4993           if (buf) retspec = buf;
4994           else if (ts) Newx(retspec,retlen+16,char);
4995           else retspec = __fileify_retbuf;
4996           cp1 = strstr(esa,"][");
4997           if (!cp1) cp1 = strstr(esa,"]<");
4998           dirlen = cp1 - esa;
4999           memcpy(retspec,esa,dirlen);
5000           if (!strncmp(cp1+2,"000000]",7)) {
5001             retspec[dirlen-1] = '\0';
5002             /* fix-me Not full ODS-5, just extra dots in directories for now */
5003             cp1 = retspec + dirlen - 1;
5004             while (cp1 > retspec)
5005             {
5006               if (*cp1 == '[')
5007                 break;
5008               if (*cp1 == '.') {
5009                 if (*(cp1-1) != '^')
5010                   break;
5011               }
5012               cp1--;
5013             }
5014             if (*cp1 == '.') *cp1 = ']';
5015             else {
5016               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5017               memmove(cp1+1,"000000]",7);
5018             }
5019           }
5020           else {
5021             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5022             retspec[retlen] = '\0';
5023             /* Convert last '.' to ']' */
5024             cp1 = retspec+retlen-1;
5025             while (*cp != '[') {
5026               cp1--;
5027               if (*cp1 == '.') {
5028                 /* Do not trip on extra dots in ODS-5 directories */
5029                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5030                 break;
5031               }
5032             }
5033             if (*cp1 == '.') *cp1 = ']';
5034             else {
5035               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5036               memmove(cp1+1,"000000]",7);
5037             }
5038           }
5039         }
5040         else {  /* This is a top-level dir.  Add the MFD to the path. */
5041           if (buf) retspec = buf;
5042           else if (ts) Newx(retspec,retlen+16,char);
5043           else retspec = __fileify_retbuf;
5044           cp1 = esa;
5045           cp2 = retspec;
5046           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5047           strcpy(cp2,":[000000]");
5048           cp1 += 2;
5049           strcpy(cp2+9,cp1);
5050         }
5051       }
5052       sts = rms_free_search_context(&dirfab);
5053       /* We've set up the string up through the filename.  Add the
5054          type and version, and we're done. */
5055       strcat(retspec,".DIR;1");
5056
5057       /* $PARSE may have upcased filespec, so convert output to lower
5058        * case if input contained any lowercase characters. */
5059       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5060       PerlMem_free(trndir);
5061       PerlMem_free(esa);
5062       PerlMem_free(vmsdir);
5063       return retspec;
5064     }
5065 }  /* end of do_fileify_dirspec() */
5066 /*}}}*/
5067 /* External entry points */
5068 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5069 { return do_fileify_dirspec(dir,buf,0); }
5070 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5071 { return do_fileify_dirspec(dir,buf,1); }
5072
5073 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5074 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
5075 {
5076     static char __pathify_retbuf[VMS_MAXRSS];
5077     unsigned long int retlen;
5078     char *retpath, *cp1, *cp2, *trndir;
5079     unsigned short int trnlnm_iter_count;
5080     STRLEN trnlen;
5081     int sts;
5082
5083     if (!dir || !*dir) {
5084       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5085     }
5086
5087     trndir = PerlMem_malloc(VMS_MAXRSS);
5088     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5089     if (*dir) strcpy(trndir,dir);
5090     else getcwd(trndir,VMS_MAXRSS - 1);
5091
5092     trnlnm_iter_count = 0;
5093     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5094            && my_trnlnm(trndir,trndir,0)) {
5095       trnlnm_iter_count++;
5096       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5097       trnlen = strlen(trndir);
5098
5099       /* Trap simple rooted lnms, and return lnm:[000000] */
5100       if (!strcmp(trndir+trnlen-2,".]")) {
5101         if (buf) retpath = buf;
5102         else if (ts) Newx(retpath,strlen(dir)+10,char);
5103         else retpath = __pathify_retbuf;
5104         strcpy(retpath,dir);
5105         strcat(retpath,":[000000]");
5106         PerlMem_free(trndir);
5107         return retpath;
5108       }
5109     }
5110
5111     /* At this point we do not work with *dir, but the copy in
5112      * *trndir that is modifiable.
5113      */
5114
5115     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5116       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5117                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5118         retlen = 2 + (*(trndir+1) != '\0');
5119       else {
5120         if ( !(cp1 = strrchr(trndir,'/')) &&
5121              !(cp1 = strrchr(trndir,']')) &&
5122              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5123         if ((cp2 = strchr(cp1,'.')) != NULL &&
5124             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5125              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5126               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5127               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5128           int ver; char *cp3;
5129
5130           /* For EFS or ODS-5 look for the last dot */
5131           if (decc_efs_charset) {
5132             cp2 = strrchr(cp1,'.');
5133           }
5134           if (vms_process_case_tolerant) {
5135               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5136                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5137                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5138                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5139                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5140                             (ver || *cp3)))))) {
5141                 PerlMem_free(trndir);
5142                 set_errno(ENOTDIR);
5143                 set_vaxc_errno(RMS$_DIR);
5144                 return NULL;
5145               }
5146           }
5147           else {
5148               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5149                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5150                   !*(cp2+3) || *(cp2+3) != 'R' ||
5151                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5152                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5153                             (ver || *cp3)))))) {
5154                 PerlMem_free(trndir);
5155                 set_errno(ENOTDIR);
5156                 set_vaxc_errno(RMS$_DIR);
5157                 return NULL;
5158               }
5159           }
5160           retlen = cp2 - trndir + 1;
5161         }
5162         else {  /* No file type present.  Treat the filename as a directory. */
5163           retlen = strlen(trndir) + 1;
5164         }
5165       }
5166       if (buf) retpath = buf;
5167       else if (ts) Newx(retpath,retlen+1,char);
5168       else retpath = __pathify_retbuf;
5169       strncpy(retpath, trndir, retlen-1);
5170       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5171         retpath[retlen-1] = '/';      /* with '/', add it. */
5172         retpath[retlen] = '\0';
5173       }
5174       else retpath[retlen-1] = '\0';
5175     }
5176     else {  /* VMS-style directory spec */
5177       char *esa, *cp;
5178       unsigned long int sts, cmplen, haslower;
5179       struct FAB dirfab = cc$rms_fab;
5180       int dirlen;
5181       rms_setup_nam(savnam);
5182       rms_setup_nam(dirnam);
5183
5184       /* If we've got an explicit filename, we can just shuffle the string. */
5185       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5186              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5187         if ((cp2 = strchr(cp1,'.')) != NULL) {
5188           int ver; char *cp3;
5189           if (vms_process_case_tolerant) {
5190               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5191                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5192                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5193                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5194                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5195                             (ver || *cp3)))))) {
5196                PerlMem_free(trndir);
5197                set_errno(ENOTDIR);
5198                set_vaxc_errno(RMS$_DIR);
5199                return NULL;
5200              }
5201           }
5202           else {
5203               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5204                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5205                   !*(cp2+3) || *(cp2+3) != 'R' ||
5206                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5207                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5208                             (ver || *cp3)))))) {
5209                PerlMem_free(trndir);
5210                set_errno(ENOTDIR);
5211                set_vaxc_errno(RMS$_DIR);
5212                return NULL;
5213              }
5214           }
5215         }
5216         else {  /* No file type, so just draw name into directory part */
5217           for (cp2 = cp1; *cp2; cp2++) ;
5218         }
5219         *cp2 = *cp1;
5220         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5221         *cp1 = '.';
5222         /* We've now got a VMS 'path'; fall through */
5223       }
5224
5225       dirlen = strlen(trndir);
5226       if (trndir[dirlen-1] == ']' ||
5227           trndir[dirlen-1] == '>' ||
5228           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5229         if (buf) retpath = buf;
5230         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5231         else retpath = __pathify_retbuf;
5232         strcpy(retpath,trndir);
5233         PerlMem_free(trndir);
5234         return retpath;
5235       }
5236       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5237       esa = PerlMem_malloc(VMS_MAXRSS);
5238       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5239       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5240       rms_bind_fab_nam(dirfab, dirnam);
5241       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5242 #ifdef NAM$M_NO_SHORT_UPCASE
5243       if (decc_efs_case_preserve)
5244           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5245 #endif
5246
5247       for (cp = trndir; *cp; cp++)
5248         if (islower(*cp)) { haslower = 1; break; }
5249
5250       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5251         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5252           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5253           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5254         }
5255         if (!sts) {
5256           PerlMem_free(trndir);
5257           PerlMem_free(esa);
5258           set_errno(EVMSERR);
5259           set_vaxc_errno(dirfab.fab$l_sts);
5260           return NULL;
5261         }
5262       }
5263       else {
5264         savnam = dirnam;
5265         /* Does the file really exist? */
5266         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5267           if (dirfab.fab$l_sts != RMS$_FNF) {
5268             int sts1;
5269             sts1 = rms_free_search_context(&dirfab);
5270             PerlMem_free(trndir);
5271             PerlMem_free(esa);
5272             set_errno(EVMSERR);
5273             set_vaxc_errno(dirfab.fab$l_sts);
5274             return NULL;
5275           }
5276           dirnam = savnam; /* No; just work with potential name */
5277         }
5278       }
5279       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5280         /* Yep; check version while we're at it, if it's there. */
5281         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5282         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5283           int sts2;
5284           /* Something other than .DIR[;1].  Bzzt. */
5285           sts2 = rms_free_search_context(&dirfab);
5286           PerlMem_free(trndir);
5287           PerlMem_free(esa);
5288           set_errno(ENOTDIR);
5289           set_vaxc_errno(RMS$_DIR);
5290           return NULL;
5291         }
5292       }
5293       /* OK, the type was fine.  Now pull any file name into the
5294          directory path. */
5295       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5296       else {
5297         cp1 = strrchr(esa,'>');
5298         *(rms_nam_typel(dirnam)) = '>';
5299       }
5300       *cp1 = '.';
5301       *(rms_nam_typel(dirnam) + 1) = '\0';
5302       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5303       if (buf) retpath = buf;
5304       else if (ts) Newx(retpath,retlen,char);
5305       else retpath = __pathify_retbuf;
5306       strcpy(retpath,esa);
5307       PerlMem_free(esa);
5308       sts = rms_free_search_context(&dirfab);
5309       /* $PARSE may have upcased filespec, so convert output to lower
5310        * case if input contained any lowercase characters. */
5311       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5312     }
5313
5314     PerlMem_free(trndir);
5315     return retpath;
5316 }  /* end of do_pathify_dirspec() */
5317 /*}}}*/
5318 /* External entry points */
5319 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5320 { return do_pathify_dirspec(dir,buf,0); }
5321 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5322 { return do_pathify_dirspec(dir,buf,1); }
5323
5324 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5325 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5326 {
5327   static char __tounixspec_retbuf[VMS_MAXRSS];
5328   char *dirend, *rslt, *cp1, *cp3, *tmp;
5329   const char *cp2;
5330   int devlen, dirlen, retlen = VMS_MAXRSS;
5331   int expand = 1; /* guarantee room for leading and trailing slashes */
5332   unsigned short int trnlnm_iter_count;
5333   int cmp_rslt;
5334
5335   if (spec == NULL) return NULL;
5336   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5337   if (buf) rslt = buf;
5338   else if (ts) {
5339     Newx(rslt, VMS_MAXRSS, char);
5340   }
5341   else rslt = __tounixspec_retbuf;
5342
5343   /* New VMS specific format needs translation
5344    * glob passes filenames with trailing '\n' and expects this preserved.
5345    */
5346   if (decc_posix_compliant_pathnames) {
5347     if (strncmp(spec, "\"^UP^", 5) == 0) {
5348       char * uspec;
5349       char *tunix;
5350       int tunix_len;
5351       int nl_flag;
5352
5353       tunix = PerlMem_malloc(VMS_MAXRSS);
5354       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5355       strcpy(tunix, spec);
5356       tunix_len = strlen(tunix);
5357       nl_flag = 0;
5358       if (tunix[tunix_len - 1] == '\n') {
5359         tunix[tunix_len - 1] = '\"';
5360         tunix[tunix_len] = '\0';
5361         tunix_len--;
5362         nl_flag = 1;
5363       }
5364       uspec = decc$translate_vms(tunix);
5365       PerlMem_free(tunix);
5366       if ((int)uspec > 0) {
5367         strcpy(rslt,uspec);
5368         if (nl_flag) {
5369           strcat(rslt,"\n");
5370         }
5371         else {
5372           /* If we can not translate it, makemaker wants as-is */
5373           strcpy(rslt, spec);
5374         }
5375         return rslt;
5376       }
5377     }
5378   }
5379
5380   cmp_rslt = 0; /* Presume VMS */
5381   cp1 = strchr(spec, '/');
5382   if (cp1 == NULL)
5383     cmp_rslt = 0;
5384
5385     /* Look for EFS ^/ */
5386     if (decc_efs_charset) {
5387       while (cp1 != NULL) {
5388         cp2 = cp1 - 1;
5389         if (*cp2 != '^') {
5390           /* Found illegal VMS, assume UNIX */
5391           cmp_rslt = 1;
5392           break;
5393         }
5394       cp1++;
5395       cp1 = strchr(cp1, '/');
5396     }
5397   }
5398
5399   /* Look for "." and ".." */
5400   if (decc_filename_unix_report) {
5401     if (spec[0] == '.') {
5402       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5403         cmp_rslt = 1;
5404       }
5405       else {
5406         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5407           cmp_rslt = 1;
5408         }
5409       }
5410     }
5411   }
5412   /* This is already UNIX or at least nothing VMS understands */
5413   if (cmp_rslt) {
5414     strcpy(rslt,spec);
5415     return rslt;
5416   }
5417
5418   cp1 = rslt;
5419   cp2 = spec;
5420   dirend = strrchr(spec,']');
5421   if (dirend == NULL) dirend = strrchr(spec,'>');
5422   if (dirend == NULL) dirend = strchr(spec,':');
5423   if (dirend == NULL) {
5424     strcpy(rslt,spec);
5425     return rslt;
5426   }
5427
5428   /* Special case 1 - sys$posix_root = / */
5429 #if __CRTL_VER >= 70000000
5430   if (!decc_disable_posix_root) {
5431     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5432       *cp1 = '/';
5433       cp1++;
5434       cp2 = cp2 + 15;
5435       }
5436   }
5437 #endif
5438
5439   /* Special case 2 - Convert NLA0: to /dev/null */
5440 #if __CRTL_VER < 70000000
5441   cmp_rslt = strncmp(spec,"NLA0:", 5);
5442   if (cmp_rslt != 0)
5443      cmp_rslt = strncmp(spec,"nla0:", 5);
5444 #else
5445   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5446 #endif
5447   if (cmp_rslt == 0) {
5448     strcpy(rslt, "/dev/null");
5449     cp1 = cp1 + 9;
5450     cp2 = cp2 + 5;
5451     if (spec[6] != '\0') {
5452       cp1[9] == '/';
5453       cp1++;
5454       cp2++;
5455     }
5456   }
5457
5458    /* Also handle special case "SYS$SCRATCH:" */
5459 #if __CRTL_VER < 70000000
5460   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5461   if (cmp_rslt != 0)
5462      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5463 #else
5464   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5465 #endif
5466   tmp = PerlMem_malloc(VMS_MAXRSS);
5467   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5468   if (cmp_rslt == 0) {
5469   int islnm;
5470
5471     islnm = my_trnlnm(tmp, "TMP", 0);
5472     if (!islnm) {
5473       strcpy(rslt, "/tmp");
5474       cp1 = cp1 + 4;
5475       cp2 = cp2 + 12;
5476       if (spec[12] != '\0') {
5477         cp1[4] == '/';
5478         cp1++;
5479         cp2++;
5480       }
5481     }
5482   }
5483
5484   if (*cp2 != '[' && *cp2 != '<') {
5485     *(cp1++) = '/';
5486   }
5487   else {  /* the VMS spec begins with directories */
5488     cp2++;
5489     if (*cp2 == ']' || *cp2 == '>') {
5490       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5491       PerlMem_free(tmp);
5492       return rslt;
5493     }
5494     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5495       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5496         if (ts) Safefree(rslt);
5497         PerlMem_free(tmp);
5498         return NULL;
5499       }
5500       trnlnm_iter_count = 0;
5501       do {
5502         cp3 = tmp;
5503         while (*cp3 != ':' && *cp3) cp3++;
5504         *(cp3++) = '\0';
5505         if (strchr(cp3,']') != NULL) break;
5506         trnlnm_iter_count++;
5507         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5508       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5509       if (ts && !buf &&
5510           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5511         retlen = devlen + dirlen;
5512         Renew(rslt,retlen+1+2*expand,char);
5513         cp1 = rslt;
5514       }
5515       cp3 = tmp;
5516       *(cp1++) = '/';
5517       while (*cp3) {
5518         *(cp1++) = *(cp3++);
5519         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5520             PerlMem_free(tmp);
5521             return NULL; /* No room */
5522         }
5523       }
5524       *(cp1++) = '/';
5525     }
5526     if ((*cp2 == '^')) {
5527         /* EFS file escape, pass the next character as is */
5528         /* Fix me: HEX encoding for UNICODE not implemented */
5529         cp2++;
5530     }
5531     else if ( *cp2 == '.') {
5532       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5533         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5534         cp2 += 3;
5535       }
5536       else cp2++;
5537     }
5538   }
5539   PerlMem_free(tmp);
5540   for (; cp2 <= dirend; cp2++) {
5541     if ((*cp2 == '^')) {
5542         /* EFS file escape, pass the next character as is */
5543         /* Fix me: HEX encoding for UNICODE not implemented */
5544         cp2++;
5545         *(cp1++) = *cp2;
5546     }
5547     if (*cp2 == ':') {
5548       *(cp1++) = '/';
5549       if (*(cp2+1) == '[') cp2++;
5550     }
5551     else if (*cp2 == ']' || *cp2 == '>') {
5552       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5553     }
5554     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5555       *(cp1++) = '/';
5556       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5557         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5558                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5559         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5560             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5561       }
5562       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5563         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5564         cp2 += 2;
5565       }
5566     }
5567     else if (*cp2 == '-') {
5568       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5569         while (*cp2 == '-') {
5570           cp2++;
5571           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5572         }
5573         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5574           if (ts) Safefree(rslt);                        /* filespecs like */
5575           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5576           return NULL;
5577         }
5578       }
5579       else *(cp1++) = *cp2;
5580     }
5581     else *(cp1++) = *cp2;
5582   }
5583   while (*cp2) *(cp1++) = *(cp2++);
5584   *cp1 = '\0';
5585
5586   /* This still leaves /000000/ when working with a
5587    * VMS device root or concealed root.
5588    */
5589   {
5590   int ulen;
5591   char * zeros;
5592
5593       ulen = strlen(rslt);
5594
5595       /* Get rid of "000000/ in rooted filespecs */
5596       if (ulen > 7) {
5597         zeros = strstr(rslt, "/000000/");
5598         if (zeros != NULL) {
5599           int mlen;
5600           mlen = ulen - (zeros - rslt) - 7;
5601           memmove(zeros, &zeros[7], mlen);
5602           ulen = ulen - 7;
5603           rslt[ulen] = '\0';
5604         }
5605       }
5606   }
5607
5608   return rslt;
5609
5610 }  /* end of do_tounixspec() */
5611 /*}}}*/
5612 /* External entry points */
5613 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5614 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5615
5616 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5617
5618 static int posix_to_vmsspec
5619   (char *vmspath, int vmspath_len, const char *unixpath) {
5620 int sts;
5621 struct FAB myfab = cc$rms_fab;
5622 struct NAML mynam = cc$rms_naml;
5623 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5624  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5625 char *esa;
5626 char *vms_delim;
5627 int dir_flag;
5628 int unixlen;
5629
5630   /* If not a posix spec already, convert it */
5631   dir_flag = 0;
5632   unixlen = strlen(unixpath);
5633   if (unixlen == 0) {
5634     vmspath[0] = '\0';
5635     return SS$_NORMAL;
5636   }
5637   if (strncmp(unixpath,"\"^UP^",5) != 0) {
5638     sprintf(vmspath,"\"^UP^%s\"",unixpath);
5639   }
5640   else {
5641     /* This is already a VMS specification, no conversion */
5642     unixlen--;
5643     strncpy(vmspath,unixpath, vmspath_len);
5644   }
5645   vmspath[vmspath_len] = 0;
5646   if (unixpath[unixlen - 1] == '/')
5647   dir_flag = 1;
5648   esa = PerlMem_malloc(VMS_MAXRSS);
5649   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5650   myfab.fab$l_fna = vmspath;
5651   myfab.fab$b_fns = strlen(vmspath);
5652   myfab.fab$l_naml = &mynam;
5653   mynam.naml$l_esa = NULL;
5654   mynam.naml$b_ess = 0;
5655   mynam.naml$l_long_expand = esa;
5656   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5657   mynam.naml$l_rsa = NULL;
5658   mynam.naml$b_rss = 0;
5659   if (decc_efs_case_preserve)
5660     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5661   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5662
5663   /* Set up the remaining naml fields */
5664   sts = sys$parse(&myfab);
5665
5666   /* It failed! Try again as a UNIX filespec */
5667   if (!(sts & 1)) {
5668     PerlMem_free(esa);
5669     return sts;
5670   }
5671
5672    /* get the Device ID and the FID */
5673    sts = sys$search(&myfab);
5674    /* on any failure, returned the POSIX ^UP^ filespec */
5675    if (!(sts & 1)) {
5676       PerlMem_free(esa);
5677       return sts;
5678    }
5679    specdsc.dsc$a_pointer = vmspath;
5680    specdsc.dsc$w_length = vmspath_len;
5681
5682    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5683    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5684    sts = lib$fid_to_name
5685       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5686
5687   /* on any failure, returned the POSIX ^UP^ filespec */
5688   if (!(sts & 1)) {
5689      /* This can happen if user does not have permission to read directories */
5690      if (strncmp(unixpath,"\"^UP^",5) != 0)
5691        sprintf(vmspath,"\"^UP^%s\"",unixpath);
5692      else
5693        strcpy(vmspath, unixpath);
5694   }
5695   else {
5696     vmspath[specdsc.dsc$w_length] = 0;
5697
5698     /* Are we expecting a directory? */
5699     if (dir_flag != 0) {
5700     int i;
5701     char *eptr;
5702
5703       eptr = NULL;
5704
5705       i = specdsc.dsc$w_length - 1;
5706       while (i > 0) {
5707       int zercnt;
5708         zercnt = 0;
5709         /* Version must be '1' */
5710         if (vmspath[i--] != '1')
5711           break;
5712         /* Version delimiter is one of ".;" */
5713         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5714           break;
5715         i--;
5716         if (vmspath[i--] != 'R')
5717           break;
5718         if (vmspath[i--] != 'I')
5719           break;
5720         if (vmspath[i--] != 'D')
5721           break;
5722         if (vmspath[i--] != '.')
5723           break;
5724         eptr = &vmspath[i+1];
5725         while (i > 0) {
5726           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5727             if (vmspath[i-1] != '^') {
5728               if (zercnt != 6) {
5729                 *eptr = vmspath[i];
5730                 eptr[1] = '\0';
5731                 vmspath[i] = '.';
5732                 break;
5733               }
5734               else {
5735                 /* Get rid of 6 imaginary zero directory filename */
5736                 vmspath[i+1] = '\0';
5737               }
5738             }
5739           }
5740           if (vmspath[i] == '0')
5741             zercnt++;
5742           else
5743             zercnt = 10;
5744           i--;
5745         }
5746         break;
5747       }
5748     }
5749   }
5750   PerlMem_free(esa);
5751   return sts;
5752 }
5753
5754 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5755 static int posix_to_vmsspec_hardway
5756   (char *vmspath, int vmspath_len, const char *unixpath) {
5757
5758 char *esa;
5759 const char *unixptr;
5760 char *vmsptr;
5761 const char *lastslash;
5762 const char *lastdot;
5763 int unixlen;
5764 int vmslen;
5765 int dir_start;
5766 int dir_dot;
5767 int quoted;
5768
5769
5770   unixptr = unixpath;
5771   dir_dot = 0;
5772
5773   /* Ignore leading "/" characters */
5774   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5775     unixptr++;
5776   }
5777   unixlen = strlen(unixptr);
5778
5779   /* Do nothing with blank paths */
5780   if (unixlen == 0) {
5781     vmspath[0] = '\0';
5782     return SS$_NORMAL;
5783   }
5784
5785   lastslash = strrchr(unixptr,'/');
5786   lastdot = strrchr(unixptr,'.');
5787
5788
5789   /* last dot is last dot or past end of string */
5790   if (lastdot == NULL)
5791     lastdot = unixptr + unixlen;
5792
5793   /* if no directories, set last slash to beginning of string */
5794   if (lastslash == NULL) {
5795     lastslash = unixptr;
5796   }
5797   else {
5798     /* Watch out for trailing "." after last slash, still a directory */
5799     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5800       lastslash = unixptr + unixlen;
5801     }
5802
5803     /* Watch out for traiing ".." after last slash, still a directory */
5804     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5805       lastslash = unixptr + unixlen;
5806     }
5807
5808     /* dots in directories are aways escaped */
5809     if (lastdot < lastslash)
5810       lastdot = unixptr + unixlen;
5811   }
5812
5813   /* if (unixptr < lastslash) then we are in a directory */
5814
5815   dir_start = 0;
5816   quoted = 0;
5817
5818   vmsptr = vmspath;
5819   vmslen = 0;
5820
5821   /* This could have a "^UP^ on the front */
5822   if (strncmp(unixptr,"\"^UP^",5) == 0) {
5823     quoted = 1;
5824     unixptr+= 5;
5825   }
5826
5827   /* Start with the UNIX path */
5828   if (*unixptr != '/') {
5829     /* relative paths */
5830     if (lastslash > unixptr) {
5831     int dotdir_seen;
5832
5833       /* skip leading ./ */
5834       dotdir_seen = 0;
5835       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5836         dotdir_seen = 1;
5837         unixptr++;
5838         unixptr++;
5839       }
5840
5841       /* Are we still in a directory? */
5842       if (unixptr <= lastslash) {
5843         *vmsptr++ = '[';
5844         vmslen = 1;
5845         dir_start = 1;
5846
5847         /* if not backing up, then it is relative forward. */
5848         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5849               ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5850           *vmsptr++ = '.';
5851           vmslen++;
5852           dir_dot = 1;
5853         }
5854        }
5855        else {
5856          if (dotdir_seen) {
5857            /* Perl wants an empty directory here to tell the difference
5858             * between a DCL commmand and a filename
5859             */
5860           *vmsptr++ = '[';
5861           *vmsptr++ = ']';
5862           vmslen = 2;
5863         }
5864       }
5865     }
5866     else {
5867       /* Handle two special files . and .. */
5868       if (unixptr[0] == '.') {
5869         if (unixptr[1] == '\0') {
5870           *vmsptr++ = '[';
5871           *vmsptr++ = ']';
5872           vmslen += 2;
5873           *vmsptr++ = '\0';
5874           return SS$_NORMAL;
5875         }
5876         if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5877           *vmsptr++ = '[';
5878           *vmsptr++ = '-';
5879           *vmsptr++ = ']';
5880           vmslen += 3;
5881           *vmsptr++ = '\0';
5882           return SS$_NORMAL;
5883         }
5884       }
5885     }
5886   }
5887   else {        /* Absolute PATH handling */
5888   int sts;
5889   char * nextslash;
5890   int seg_len;
5891     /* Need to find out where root is */
5892
5893     /* In theory, this procedure should never get an absolute POSIX pathname
5894      * that can not be found on the POSIX root.
5895      * In practice, that can not be relied on, and things will show up
5896      * here that are a VMS device name or concealed logical name instead.
5897      * So to make things work, this procedure must be tolerant.
5898      */
5899     esa = PerlMem_malloc(vmspath_len);
5900     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5901
5902     sts = SS$_NORMAL;
5903     nextslash = strchr(&unixptr[1],'/');
5904     seg_len = 0;
5905     if (nextslash != NULL) {
5906       seg_len = nextslash - &unixptr[1];
5907       strncpy(vmspath, unixptr, seg_len + 1);
5908       vmspath[seg_len+1] = 0;
5909       sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5910     }
5911
5912     if (sts & 1) {
5913       /* This is verified to be a real path */
5914
5915       sts = posix_to_vmsspec(esa, vmspath_len, "/");
5916       strcpy(vmspath, esa);
5917       vmslen = strlen(vmspath);
5918       vmsptr = vmspath + vmslen;
5919       unixptr++;
5920       if (unixptr < lastslash) {
5921       char * rptr;
5922         vmsptr--;
5923         *vmsptr++ = '.';
5924         dir_start = 1;
5925         dir_dot = 1;
5926         if (vmslen > 7) {
5927         int cmp;
5928           rptr = vmsptr - 7;
5929           cmp = strcmp(rptr,"000000.");
5930           if (cmp == 0) {
5931             vmslen -= 7;
5932             vmsptr -= 7;
5933             vmsptr[1] = '\0';
5934           } /* removing 6 zeros */
5935         } /* vmslen < 7, no 6 zeros possible */
5936       } /* Not in a directory */
5937     } /* end of verified real path handling */
5938     else {
5939     int add_6zero;
5940     int islnm;
5941
5942       /* Ok, we have a device or a concealed root that is not in POSIX
5943        * or we have garbage.  Make the best of it.
5944        */
5945
5946       /* Posix to VMS destroyed this, so copy it again */
5947       strncpy(vmspath, &unixptr[1], seg_len);
5948       vmspath[seg_len] = 0;
5949       vmslen = seg_len;
5950       vmsptr = &vmsptr[vmslen];
5951       islnm = 0;
5952
5953       /* Now do we need to add the fake 6 zero directory to it? */
5954       add_6zero = 1;
5955       if ((*lastslash == '/') && (nextslash < lastslash)) {
5956         /* No there is another directory */
5957         add_6zero = 0;
5958       }
5959       else {
5960       int trnend;
5961
5962         /* now we have foo:bar or foo:[000000]bar to decide from */
5963         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
5964         trnend = islnm ? islnm - 1 : 0;
5965
5966         /* if this was a logical name, ']' or '>' must be present */
5967         /* if not a logical name, then assume a device and hope. */
5968         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
5969
5970         /* if log name and trailing '.' then rooted - treat as device */
5971         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
5972
5973         /* Fix me, if not a logical name, a device lookup should be
5974          * done to see if the device is file structured.  If the device
5975          * is not file structured, the 6 zeros should not be put on.
5976          *
5977          * As it is, perl is occasionally looking for dev:[000000]tty.
5978          * which looks a little strange.
5979          */
5980
5981         if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
5982           /* No real directory present */
5983           add_6zero = 1;
5984         }
5985       }
5986
5987       /* Put the device delimiter on */
5988       *vmsptr++ = ':';
5989       vmslen++;
5990       unixptr = nextslash;
5991       unixptr++;
5992
5993       /* Start directory if needed */
5994       if (!islnm || add_6zero) {
5995         *vmsptr++ = '[';
5996         vmslen++;
5997         dir_start = 1;
5998       }
5999
6000       /* add fake 000000] if needed */
6001       if (add_6zero) {
6002         *vmsptr++ = '0';
6003         *vmsptr++ = '0';
6004         *vmsptr++ = '0';
6005         *vmsptr++ = '0';
6006         *vmsptr++ = '0';
6007         *vmsptr++ = '0';
6008         *vmsptr++ = ']';
6009         vmslen += 7;
6010         dir_start = 0;
6011       }
6012
6013     } /* non-POSIX translation */
6014     PerlMem_free(esa);
6015   } /* End of relative/absolute path handling */
6016
6017   while ((*unixptr) && (vmslen < vmspath_len)){
6018   int dash_flag;
6019
6020     dash_flag = 0;
6021
6022     if (dir_start != 0) {
6023
6024       /* First characters in a directory are handled special */
6025       while ((*unixptr == '/') ||
6026              ((*unixptr == '.') &&
6027               ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
6028       int loop_flag;
6029
6030         loop_flag = 0;
6031
6032         /* Skip redundant / in specification */
6033         while ((*unixptr == '/') && (dir_start != 0)) {
6034           loop_flag = 1;
6035           unixptr++;
6036           if (unixptr == lastslash)
6037             break;
6038         }
6039         if (unixptr == lastslash)
6040           break;
6041
6042         /* Skip redundant ./ characters */
6043         while ((*unixptr == '.') &&
6044                ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
6045           loop_flag = 1;
6046           unixptr++;
6047           if (unixptr == lastslash)
6048             break;
6049           if (*unixptr == '/')
6050             unixptr++;
6051         }
6052         if (unixptr == lastslash)
6053           break;
6054
6055         /* Skip redundant ../ characters */
6056         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6057              ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
6058           /* Set the backing up flag */
6059           loop_flag = 1;
6060           dir_dot = 0;
6061           dash_flag = 1;
6062           *vmsptr++ = '-';
6063           vmslen++;
6064           unixptr++; /* first . */
6065           unixptr++; /* second . */
6066           if (unixptr == lastslash)
6067             break;
6068           if (*unixptr == '/') /* The slash */
6069             unixptr++;
6070         }
6071         if (unixptr == lastslash)
6072           break;
6073
6074         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6075         /* Not needed when VMS is pretending to be UNIX. */
6076
6077         /* Is this loop stuck because of too many dots? */
6078         if (loop_flag == 0) {
6079           /* Exit the loop and pass the rest through */
6080           break;
6081         }
6082       }
6083
6084       /* Are we done with directories yet? */
6085       if (unixptr >= lastslash) {
6086
6087         /* Watch out for trailing dots */
6088         if (dir_dot != 0) {
6089             vmslen --;
6090             vmsptr--;
6091         }
6092         *vmsptr++ = ']';
6093         vmslen++;
6094         dash_flag = 0;
6095         dir_start = 0;
6096         if (*unixptr == '/')
6097           unixptr++;
6098       }
6099       else {
6100         /* Have we stopped backing up? */
6101         if (dash_flag) {
6102           *vmsptr++ = '.';
6103           vmslen++;
6104           dash_flag = 0;
6105           /* dir_start continues to be = 1 */
6106         }
6107         if (*unixptr == '-') {
6108           *vmsptr++ = '^';
6109           *vmsptr++ = *unixptr++;
6110           vmslen += 2;
6111           dir_start = 0;
6112
6113           /* Now are we done with directories yet? */
6114           if (unixptr >= lastslash) {
6115
6116             /* Watch out for trailing dots */
6117             if (dir_dot != 0) {
6118               vmslen --;
6119               vmsptr--;
6120             }
6121
6122             *vmsptr++ = ']';
6123             vmslen++;
6124             dash_flag = 0;
6125             dir_start = 0;
6126           }
6127         }
6128       }
6129     }
6130
6131     /* All done? */
6132     if (*unixptr == '\0')
6133       break;
6134
6135     /* Normal characters - More EFS work probably needed */
6136     dir_start = 0;
6137     dir_dot = 0;
6138
6139     switch(*unixptr) {
6140     case '/':
6141         /* remove multiple / */
6142         while (unixptr[1] == '/') {
6143            unixptr++;
6144         }
6145         if (unixptr == lastslash) {
6146           /* Watch out for trailing dots */
6147           if (dir_dot != 0) {
6148             vmslen --;
6149             vmsptr--;
6150           }
6151           *vmsptr++ = ']';
6152         }
6153         else {
6154           dir_start = 1;
6155           *vmsptr++ = '.';
6156           dir_dot = 1;
6157
6158           /* To do: Perl expects /.../ to be translated to [...] on VMS */
6159           /* Not needed when VMS is pretending to be UNIX. */
6160
6161         }
6162         dash_flag = 0;
6163         if (*unixptr != '\0')
6164           unixptr++;
6165         vmslen++;
6166         break;
6167     case '?':
6168         *vmsptr++ = '%';
6169         vmslen++;
6170         unixptr++;
6171         break;
6172     case ' ':
6173         *vmsptr++ = '^';
6174         *vmsptr++ = '_';
6175         vmslen += 2;
6176         unixptr++;
6177         break;
6178     case '.':
6179         if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
6180           *vmsptr++ = '^';
6181           *vmsptr++ = '.';
6182           vmslen += 2;
6183           unixptr++;
6184
6185           /* trailing dot ==> '^..' on VMS */
6186           if (*unixptr == '\0') {
6187             *vmsptr++ = '.';
6188             vmslen++;
6189           }
6190           *vmsptr++ = *unixptr++;
6191           vmslen ++;
6192         }
6193         if (quoted && (unixptr[1] == '\0')) {
6194           unixptr++;
6195           break;
6196         }
6197         *vmsptr++ = '^';
6198         *vmsptr++ = *unixptr++;
6199         vmslen += 2;
6200         break;
6201     case '~':
6202     case ';':
6203     case '\\':
6204         *vmsptr++ = '^';
6205         *vmsptr++ = *unixptr++;
6206         vmslen += 2;
6207         break;
6208     default:
6209         if (*unixptr != '\0') {
6210           *vmsptr++ = *unixptr++;
6211           vmslen++;
6212         }
6213         break;
6214     }
6215   }
6216
6217   /* Make sure directory is closed */
6218   if (unixptr == lastslash) {
6219     char *vmsptr2;
6220     vmsptr2 = vmsptr - 1;
6221
6222     if (*vmsptr2 != ']') {
6223       *vmsptr2--;
6224
6225       /* directories do not end in a dot bracket */
6226       if (*vmsptr2 == '.') {
6227         vmsptr2--;
6228
6229         /* ^. is allowed */
6230         if (*vmsptr2 != '^') {
6231           vmsptr--; /* back up over the dot */
6232         }
6233       }
6234       *vmsptr++ = ']';
6235     }
6236   }
6237   else {
6238     char *vmsptr2;
6239     /* Add a trailing dot if a file with no extension */
6240     vmsptr2 = vmsptr - 1;
6241     if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6242         (*lastdot != '.')) {
6243         *vmsptr++ = '.';
6244         vmslen++;
6245     }
6246   }
6247
6248   *vmsptr = '\0';
6249   return SS$_NORMAL;
6250 }
6251 #endif
6252
6253 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6254 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6255   static char __tovmsspec_retbuf[VMS_MAXRSS];
6256   char *rslt, *dirend;
6257   char *lastdot;
6258   char *vms_delim;
6259   register char *cp1;
6260   const char *cp2;
6261   unsigned long int infront = 0, hasdir = 1;
6262   int rslt_len;
6263   int no_type_seen;
6264
6265   if (path == NULL) return NULL;
6266   rslt_len = VMS_MAXRSS-1;
6267   if (buf) rslt = buf;
6268   else if (ts) Newx(rslt, VMS_MAXRSS, char);
6269   else rslt = __tovmsspec_retbuf;
6270   if (strpbrk(path,"]:>") ||
6271       (dirend = strrchr(path,'/')) == NULL) {
6272     if (path[0] == '.') {
6273       if (path[1] == '\0') strcpy(rslt,"[]");
6274       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6275       else strcpy(rslt,path); /* probably garbage */
6276     }
6277     else strcpy(rslt,path);
6278     return rslt;
6279   }
6280
6281    /* Posix specifications are now a native VMS format */
6282   /*--------------------------------------------------*/
6283 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6284   if (decc_posix_compliant_pathnames) {
6285     if (strncmp(path,"\"^UP^",5) == 0) {
6286       posix_to_vmsspec_hardway(rslt, rslt_len, path);
6287       return rslt;
6288     }
6289   }
6290 #endif
6291
6292   vms_delim = strpbrk(path,"]:>");
6293
6294   if ((vms_delim != NULL) ||
6295       ((dirend = strrchr(path,'/')) == NULL)) {
6296
6297     /* VMS special characters found! */
6298
6299     if (path[0] == '.') {
6300       if (path[1] == '\0') strcpy(rslt,"[]");
6301       else if (path[1] == '.' && path[2] == '\0')
6302         strcpy(rslt,"[-]");
6303
6304       /* Dot preceeding a device or directory ? */
6305       else {
6306         /* If not in POSIX mode, pass it through and hope it works */
6307 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6308         if (!decc_posix_compliant_pathnames)
6309           strcpy(rslt,path); /* probably garbage */
6310         else
6311           posix_to_vmsspec_hardway(rslt, rslt_len, path);
6312 #else
6313         strcpy(rslt,path); /* probably garbage */
6314 #endif
6315       }
6316     }
6317     else {
6318
6319        /* If no VMS characters and in POSIX mode, convert it!
6320         * This is the easiest way to get directory specifications
6321         * handled correctly in POSIX mode
6322         */
6323 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6324       if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6325         posix_to_vmsspec_hardway(rslt, rslt_len, path);
6326       else {
6327         /* No unix path separators - presume VMS already */
6328         strcpy(rslt,path);
6329       }
6330 #else
6331       strcpy(rslt,path); /* probably garbage */
6332 #endif
6333     }
6334     return rslt;
6335   }
6336
6337 /* If POSIX mode active, handle the conversion */
6338 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6339   if (decc_posix_compliant_pathnames) {
6340     posix_to_vmsspec_hardway(rslt, rslt_len, path);
6341     return rslt;
6342   }
6343 #endif
6344
6345   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
6346     if (!*(dirend+2)) dirend +=2;
6347     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6348     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6349   }
6350
6351   cp1 = rslt;
6352   cp2 = path;
6353   lastdot = strrchr(cp2,'.');
6354   if (*cp2 == '/') {
6355     char *trndev;
6356     int islnm, rooted;
6357     STRLEN trnend;
6358
6359     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6360     if (!*(cp2+1)) {
6361       if (decc_disable_posix_root) {
6362         strcpy(rslt,"sys$disk:[000000]");
6363       }
6364       else {
6365         strcpy(rslt,"sys$posix_root:[000000]");
6366       }
6367       return rslt;
6368     }
6369     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6370     *cp1 = '\0';
6371     trndev = PerlMem_malloc(VMS_MAXRSS);
6372     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
6373     islnm =  my_trnlnm(rslt,trndev,0);
6374
6375      /* DECC special handling */
6376     if (!islnm) {
6377       if (strcmp(rslt,"bin") == 0) {
6378         strcpy(rslt,"sys$system");
6379         cp1 = rslt + 10;
6380         *cp1 = 0;
6381         islnm =  my_trnlnm(rslt,trndev,0);
6382       }
6383       else if (strcmp(rslt,"tmp") == 0) {
6384         strcpy(rslt,"sys$scratch");
6385         cp1 = rslt + 11;
6386         *cp1 = 0;
6387         islnm =  my_trnlnm(rslt,trndev,0);
6388       }
6389       else if (!decc_disable_posix_root) {
6390         strcpy(rslt, "sys$posix_root");
6391         cp1 = rslt + 13;
6392         *cp1 = 0;
6393         cp2 = path;
6394         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6395         islnm =  my_trnlnm(rslt,trndev,0);
6396       }
6397       else if (strcmp(rslt,"dev") == 0) {
6398         if (strncmp(cp2,"/null", 5) == 0) {
6399           if ((cp2[5] == 0) || (cp2[5] == '/')) {
6400             strcpy(rslt,"NLA0");
6401             cp1 = rslt + 4;
6402             *cp1 = 0;
6403             cp2 = cp2 + 5;
6404             islnm =  my_trnlnm(rslt,trndev,0);
6405           }
6406         }
6407       }
6408     }
6409
6410     trnend = islnm ? strlen(trndev) - 1 : 0;
6411     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6412     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6413     /* If the first element of the path is a logical name, determine
6414      * whether it has to be translated so we can add more directories. */
6415     if (!islnm || rooted) {
6416       *(cp1++) = ':';
6417       *(cp1++) = '[';
6418       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6419       else cp2++;
6420     }
6421     else {
6422       if (cp2 != dirend) {
6423         strcpy(rslt,trndev);
6424         cp1 = rslt + trnend;
6425         if (*cp2 != 0) {
6426           *(cp1++) = '.';
6427           cp2++;
6428         }
6429       }
6430       else {
6431         if (decc_disable_posix_root) {
6432           *(cp1++) = ':';
6433           hasdir = 0;
6434         }
6435       }
6436     }
6437     PerlMem_free(trndev);
6438   }
6439   else {
6440     *(cp1++) = '[';
6441     if (*cp2 == '.') {
6442       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6443         cp2 += 2;         /* skip over "./" - it's redundant */
6444         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
6445       }
6446       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6447         *(cp1++) = '-';                                 /* "../" --> "-" */
6448         cp2 += 3;
6449       }
6450       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6451                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6452         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6453         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6454         cp2 += 4;
6455       }
6456       else if ((cp2 != lastdot) || (lastdot < dirend)) {
6457         /* Escape the extra dots in EFS file specifications */
6458         *(cp1++) = '^';
6459       }
6460       if (cp2 > dirend) cp2 = dirend;
6461     }
6462     else *(cp1++) = '.';
6463   }
6464   for (; cp2 < dirend; cp2++) {
6465     if (*cp2 == '/') {
6466       if (*(cp2-1) == '/') continue;
6467       if (*(cp1-1) != '.') *(cp1++) = '.';
6468       infront = 0;
6469     }
6470     else if (!infront && *cp2 == '.') {
6471       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6472       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
6473       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6474         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6475         else if (*(cp1-2) == '[') *(cp1-1) = '-';
6476         else {  /* back up over previous directory name */
6477           cp1--;
6478           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6479           if (*(cp1-1) == '[') {
6480             memcpy(cp1,"000000.",7);
6481             cp1 += 7;
6482           }
6483         }
6484         cp2 += 2;
6485         if (cp2 == dirend) break;
6486       }
6487       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6488                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6489         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6490         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6491         if (!*(cp2+3)) {
6492           *(cp1++) = '.';  /* Simulate trailing '/' */
6493           cp2 += 2;  /* for loop will incr this to == dirend */
6494         }
6495         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
6496       }
6497       else {
6498         if (decc_efs_charset == 0)
6499           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
6500         else {
6501           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
6502           *(cp1++) = '.';
6503         }
6504       }
6505     }
6506     else {
6507       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
6508       if (*cp2 == '.') {
6509         if (decc_efs_charset == 0)
6510           *(cp1++) = '_';
6511         else {
6512           *(cp1++) = '^';
6513           *(cp1++) = '.';
6514         }
6515       }
6516       else                  *(cp1++) =  *cp2;
6517       infront = 1;
6518     }
6519   }
6520   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6521   if (hasdir) *(cp1++) = ']';
6522   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
6523   /* fixme for ODS5 */
6524   no_type_seen = 0;
6525   if (cp2 > lastdot)
6526     no_type_seen = 1;
6527   while (*cp2) {
6528     switch(*cp2) {
6529     case '?':
6530         *(cp1++) = '%';
6531         cp2++;
6532     case ' ':
6533         *(cp1)++ = '^';
6534         *(cp1)++ = '_';
6535         cp2++;
6536         break;
6537     case '.':
6538         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6539             decc_readdir_dropdotnotype) {
6540           *(cp1)++ = '^';
6541           *(cp1)++ = '.';
6542           cp2++;
6543
6544           /* trailing dot ==> '^..' on VMS */
6545           if (*cp2 == '\0') {
6546             *(cp1++) = '.';
6547             no_type_seen = 0;
6548           }
6549         }
6550         else {
6551           *(cp1++) = *(cp2++);
6552           no_type_seen = 0;
6553         }
6554         break;
6555     case '\"':
6556     case '~':
6557     case '`':
6558     case '!':
6559     case '#':
6560     case '%':
6561     case '^':
6562     case '&':
6563     case '(':
6564     case ')':
6565     case '=':
6566     case '+':
6567     case '\'':
6568     case '@':
6569     case '[':
6570     case ']':
6571     case '{':
6572     case '}':
6573     case ':':
6574     case '\\':
6575     case '|':
6576     case '<':
6577     case '>':
6578         *(cp1++) = '^';
6579         *(cp1++) = *(cp2++);
6580         break;
6581     case ';':
6582         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6583          * which is wrong.  UNIX notation should be ".dir." unless
6584          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6585          * changing this behavior could break more things at this time.
6586          * efs character set effectively does not allow "." to be a version
6587          * delimiter as a further complication about changing this.
6588          */
6589         if (decc_filename_unix_report != 0) {
6590           *(cp1++) = '^';
6591         }
6592         *(cp1++) = *(cp2++);
6593         break;
6594     default:
6595         *(cp1++) = *(cp2++);
6596     }
6597   }
6598   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6599   char *lcp1;
6600     lcp1 = cp1;
6601     lcp1--;
6602      /* Fix me for "^]", but that requires making sure that you do
6603       * not back up past the start of the filename
6604       */
6605     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6606       *cp1++ = '.';
6607   }
6608   *cp1 = '\0';
6609
6610   return rslt;
6611
6612 }  /* end of do_tovmsspec() */
6613 /*}}}*/
6614 /* External entry points */
6615 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6616 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6617
6618 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6619 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6620   static char __tovmspath_retbuf[VMS_MAXRSS];
6621   int vmslen;
6622   char *pathified, *vmsified, *cp;
6623
6624   if (path == NULL) return NULL;
6625   pathified = PerlMem_malloc(VMS_MAXRSS);
6626   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
6627   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6628     PerlMem_free(pathified);
6629     return NULL;
6630   }
6631
6632   vmsified = NULL;
6633   if (buf == NULL)
6634      Newx(vmsified, VMS_MAXRSS, char);
6635   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0) == NULL) {
6636     PerlMem_free(pathified);
6637     if (vmsified) Safefree(vmsified);
6638     return NULL;
6639   }
6640   PerlMem_free(pathified);
6641   if (buf) {
6642     return buf;
6643   }
6644   else if (ts) {
6645     vmslen = strlen(vmsified);
6646     Newx(cp,vmslen+1,char);
6647     memcpy(cp,vmsified,vmslen);
6648     cp[vmslen] = '\0';
6649     Safefree(vmsified);
6650     return cp;
6651   }
6652   else {
6653     strcpy(__tovmspath_retbuf,vmsified);
6654     Safefree(vmsified);
6655     return __tovmspath_retbuf;
6656   }
6657
6658 }  /* end of do_tovmspath() */
6659 /*}}}*/
6660 /* External entry points */
6661 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6662 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6663
6664
6665 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6666 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6667   static char __tounixpath_retbuf[VMS_MAXRSS];
6668   int unixlen;
6669   char *pathified, *unixified, *cp;
6670
6671   if (path == NULL) return NULL;
6672   pathified = PerlMem_malloc(VMS_MAXRSS);
6673   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
6674   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6675     PerlMem_free(pathified);
6676     return NULL;
6677   }
6678
6679   unixified = NULL;
6680   if (buf == NULL) {
6681       Newx(unixified, VMS_MAXRSS, char);
6682   }
6683   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6684     PerlMem_free(pathified);
6685     if (unixified) Safefree(unixified);
6686     return NULL;
6687   }
6688   PerlMem_free(pathified);
6689   if (buf) {
6690     return buf;
6691   }
6692   else if (ts) {
6693     unixlen = strlen(unixified);
6694     Newx(cp,unixlen+1,char);
6695     memcpy(cp,unixified,unixlen);
6696     cp[unixlen] = '\0';
6697     Safefree(unixified);
6698     return cp;
6699   }
6700   else {
6701     strcpy(__tounixpath_retbuf,unixified);
6702     Safefree(unixified);
6703     return __tounixpath_retbuf;
6704   }
6705
6706 }  /* end of do_tounixpath() */
6707 /*}}}*/
6708 /* External entry points */
6709 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6710 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6711
6712 /*
6713  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
6714  *
6715  *****************************************************************************
6716  *                                                                           *
6717  *  Copyright (C) 1989-1994 by                                               *
6718  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
6719  *                                                                           *
6720  *  Permission is hereby  granted for the reproduction of this software,     *
6721  *  on condition that this copyright notice is included in the reproduction, *
6722  *  and that such reproduction is not for purposes of profit or material     *
6723  *  gain.                                                                    *
6724  *                                                                           *
6725  *  27-Aug-1994 Modified for inclusion in perl5                              *
6726  *              by Charles Bailey  bailey@newman.upenn.edu                   *
6727  *****************************************************************************
6728  */
6729
6730 /*
6731  * getredirection() is intended to aid in porting C programs
6732  * to VMS (Vax-11 C).  The native VMS environment does not support
6733  * '>' and '<' I/O redirection, or command line wild card expansion,
6734  * or a command line pipe mechanism using the '|' AND background
6735  * command execution '&'.  All of these capabilities are provided to any
6736  * C program which calls this procedure as the first thing in the
6737  * main program.
6738  * The piping mechanism will probably work with almost any 'filter' type
6739  * of program.  With suitable modification, it may useful for other
6740  * portability problems as well.
6741  *
6742  * Author:  Mark Pizzolato      mark@infocomm.com
6743  */
6744 struct list_item
6745     {
6746     struct list_item *next;
6747     char *value;
6748     };
6749
6750 static void add_item(struct list_item **head,
6751                      struct list_item **tail,
6752                      char *value,
6753                      int *count);
6754
6755 static void mp_expand_wild_cards(pTHX_ char *item,
6756                                 struct list_item **head,
6757                                 struct list_item **tail,
6758                                 int *count);
6759
6760 static int background_process(pTHX_ int argc, char **argv);
6761
6762 static void pipe_and_fork(pTHX_ char **cmargv);
6763
6764 /*{{{ void getredirection(int *ac, char ***av)*/
6765 static void
6766 mp_getredirection(pTHX_ int *ac, char ***av)
6767 /*
6768  * Process vms redirection arg's.  Exit if any error is seen.
6769  * If getredirection() processes an argument, it is erased
6770  * from the vector.  getredirection() returns a new argc and argv value.
6771  * In the event that a background command is requested (by a trailing "&"),
6772  * this routine creates a background subprocess, and simply exits the program.
6773  *
6774  * Warning: do not try to simplify the code for vms.  The code
6775  * presupposes that getredirection() is called before any data is
6776  * read from stdin or written to stdout.
6777  *
6778  * Normal usage is as follows:
6779  *
6780  *      main(argc, argv)
6781  *      int             argc;
6782  *      char            *argv[];
6783  *      {
6784  *              getredirection(&argc, &argv);
6785  *      }
6786  */
6787 {
6788     int                 argc = *ac;     /* Argument Count         */
6789     char                **argv = *av;   /* Argument Vector        */
6790     char                *ap;            /* Argument pointer       */
6791     int                 j;              /* argv[] index           */
6792     int                 item_count = 0; /* Count of Items in List */
6793     struct list_item    *list_head = 0; /* First Item in List       */
6794     struct list_item    *list_tail;     /* Last Item in List        */
6795     char                *in = NULL;     /* Input File Name          */
6796     char                *out = NULL;    /* Output File Name         */
6797     char                *outmode = "w"; /* Mode to Open Output File */
6798     char                *err = NULL;    /* Error File Name          */
6799     char                *errmode = "w"; /* Mode to Open Error File  */
6800     int                 cmargc = 0;     /* Piped Command Arg Count  */
6801     char                **cmargv = NULL;/* Piped Command Arg Vector */
6802
6803     /*
6804      * First handle the case where the last thing on the line ends with
6805      * a '&'.  This indicates the desire for the command to be run in a
6806      * subprocess, so we satisfy that desire.
6807      */
6808     ap = argv[argc-1];
6809     if (0 == strcmp("&", ap))
6810        exit(background_process(aTHX_ --argc, argv));
6811     if (*ap && '&' == ap[strlen(ap)-1])
6812         {
6813         ap[strlen(ap)-1] = '\0';
6814        exit(background_process(aTHX_ argc, argv));
6815         }
6816     /*
6817      * Now we handle the general redirection cases that involve '>', '>>',
6818      * '<', and pipes '|'.
6819      */
6820     for (j = 0; j < argc; ++j)
6821         {
6822         if (0 == strcmp("<", argv[j]))
6823             {
6824             if (j+1 >= argc)
6825                 {
6826                 fprintf(stderr,"No input file after < on command line");
6827                 exit(LIB$_WRONUMARG);
6828                 }
6829             in = argv[++j];
6830             continue;
6831             }
6832         if ('<' == *(ap = argv[j]))
6833             {
6834             in = 1 + ap;
6835             continue;
6836             }
6837         if (0 == strcmp(">", ap))
6838             {
6839             if (j+1 >= argc)
6840                 {
6841                 fprintf(stderr,"No output file after > on command line");
6842                 exit(LIB$_WRONUMARG);
6843                 }
6844             out = argv[++j];
6845             continue;
6846             }
6847         if ('>' == *ap)
6848             {
6849             if ('>' == ap[1])
6850                 {
6851                 outmode = "a";
6852                 if ('\0' == ap[2])
6853                     out = argv[++j];
6854                 else
6855                     out = 2 + ap;
6856                 }
6857             else
6858                 out = 1 + ap;
6859             if (j >= argc)
6860                 {
6861                 fprintf(stderr,"No output file after > or >> on command line");
6862                 exit(LIB$_WRONUMARG);
6863                 }
6864             continue;
6865             }
6866         if (('2' == *ap) && ('>' == ap[1]))
6867             {
6868             if ('>' == ap[2])
6869                 {
6870                 errmode = "a";
6871                 if ('\0' == ap[3])
6872                     err = argv[++j];
6873                 else
6874                     err = 3 + ap;
6875                 }
6876             else
6877                 if ('\0' == ap[2])
6878                     err = argv[++j];
6879                 else
6880                     err = 2 + ap;
6881             if (j >= argc)
6882                 {
6883                 fprintf(stderr,"No output file after 2> or 2>> on command line");
6884                 exit(LIB$_WRONUMARG);
6885                 }
6886             continue;
6887             }
6888         if (0 == strcmp("|", argv[j]))
6889             {
6890             if (j+1 >= argc)
6891                 {
6892                 fprintf(stderr,"No command into which to pipe on command line");
6893                 exit(LIB$_WRONUMARG);
6894                 }
6895             cmargc = argc-(j+1);
6896             cmargv = &argv[j+1];
6897             argc = j;
6898             continue;
6899             }
6900         if ('|' == *(ap = argv[j]))
6901             {
6902             ++argv[j];
6903             cmargc = argc-j;
6904             cmargv = &argv[j];
6905             argc = j;
6906             continue;
6907             }
6908         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6909         }
6910     /*
6911      * Allocate and fill in the new argument vector, Some Unix's terminate
6912      * the list with an extra null pointer.
6913      */
6914     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
6915     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6916     *av = argv;
6917     for (j = 0; j < item_count; ++j, list_head = list_head->next)
6918         argv[j] = list_head->value;
6919     *ac = item_count;
6920     if (cmargv != NULL)
6921         {
6922         if (out != NULL)
6923             {
6924             fprintf(stderr,"'|' and '>' may not both be specified on command line");
6925             exit(LIB$_INVARGORD);
6926             }
6927         pipe_and_fork(aTHX_ cmargv);
6928         }
6929
6930     /* Check for input from a pipe (mailbox) */
6931
6932     if (in == NULL && 1 == isapipe(0))
6933         {
6934         char mbxname[L_tmpnam];
6935         long int bufsize;
6936         long int dvi_item = DVI$_DEVBUFSIZ;
6937         $DESCRIPTOR(mbxnam, "");
6938         $DESCRIPTOR(mbxdevnam, "");
6939
6940         /* Input from a pipe, reopen it in binary mode to disable       */
6941         /* carriage control processing.                                 */
6942
6943         fgetname(stdin, mbxname);
6944         mbxnam.dsc$a_pointer = mbxname;
6945         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6946         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6947         mbxdevnam.dsc$a_pointer = mbxname;
6948         mbxdevnam.dsc$w_length = sizeof(mbxname);
6949         dvi_item = DVI$_DEVNAM;
6950         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6951         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
6952         set_errno(0);
6953         set_vaxc_errno(1);
6954         freopen(mbxname, "rb", stdin);
6955         if (errno != 0)
6956             {
6957             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
6958             exit(vaxc$errno);
6959             }
6960         }
6961     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6962         {
6963         fprintf(stderr,"Can't open input file %s as stdin",in);
6964         exit(vaxc$errno);
6965         }
6966     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
6967         {
6968         fprintf(stderr,"Can't open output file %s as stdout",out);
6969         exit(vaxc$errno);
6970         }
6971         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
6972
6973     if (err != NULL) {
6974         if (strcmp(err,"&1") == 0) {
6975             dup2(fileno(stdout), fileno(stderr));
6976             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
6977         } else {
6978         FILE *tmperr;
6979         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
6980             {
6981             fprintf(stderr,"Can't open error file %s as stderr",err);
6982             exit(vaxc$errno);
6983             }
6984             fclose(tmperr);
6985            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
6986                 {
6987                 exit(vaxc$errno);
6988                 }
6989             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
6990         }
6991         }
6992 #ifdef ARGPROC_DEBUG
6993     PerlIO_printf(Perl_debug_log, "Arglist:\n");
6994     for (j = 0; j < *ac;  ++j)
6995         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
6996 #endif
6997    /* Clear errors we may have hit expanding wildcards, so they don't
6998       show up in Perl's $! later */
6999    set_errno(0); set_vaxc_errno(1);
7000 }  /* end of getredirection() */
7001 /*}}}*/
7002
7003 static void add_item(struct list_item **head,
7004                      struct list_item **tail,
7005                      char *value,
7006                      int *count)
7007 {
7008     if (*head == 0)
7009         {
7010         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7011         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7012         *tail = *head;
7013         }
7014     else {
7015         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7016         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7017         *tail = (*tail)->next;
7018         }
7019     (*tail)->value = value;
7020     ++(*count);
7021 }
7022
7023 static void mp_expand_wild_cards(pTHX_ char *item,
7024                               struct list_item **head,
7025                               struct list_item **tail,
7026                               int *count)
7027 {
7028 int expcount = 0;
7029 unsigned long int context = 0;
7030 int isunix = 0;
7031 int item_len = 0;
7032 char *had_version;
7033 char *had_device;
7034 int had_directory;
7035 char *devdir,*cp;
7036 char *vmsspec;
7037 $DESCRIPTOR(filespec, "");
7038 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7039 $DESCRIPTOR(resultspec, "");
7040 unsigned long int lff_flags = 0;
7041 int sts;
7042 int rms_sts;
7043
7044 #ifdef VMS_LONGNAME_SUPPORT
7045     lff_flags = LIB$M_FIL_LONG_NAMES;
7046 #endif
7047
7048     for (cp = item; *cp; cp++) {
7049         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7050         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7051     }
7052     if (!*cp || isspace(*cp))
7053         {
7054         add_item(head, tail, item, count);
7055         return;
7056         }
7057     else
7058         {
7059      /* "double quoted" wild card expressions pass as is */
7060      /* From DCL that means using e.g.:                  */
7061      /* perl program """perl.*"""                        */
7062      item_len = strlen(item);
7063      if ( '"' == *item && '"' == item[item_len-1] )
7064        {
7065        item++;
7066        item[item_len-2] = '\0';
7067        add_item(head, tail, item, count);
7068        return;
7069        }
7070      }
7071     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7072     resultspec.dsc$b_class = DSC$K_CLASS_D;
7073     resultspec.dsc$a_pointer = NULL;
7074     vmsspec = PerlMem_malloc(VMS_MAXRSS);
7075     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7076     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7077       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
7078     if (!isunix || !filespec.dsc$a_pointer)
7079       filespec.dsc$a_pointer = item;
7080     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7081     /*
7082      * Only return version specs, if the caller specified a version
7083      */
7084     had_version = strchr(item, ';');
7085     /*
7086      * Only return device and directory specs, if the caller specifed either.
7087      */
7088     had_device = strchr(item, ':');
7089     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7090
7091     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7092                                  (&filespec, &resultspec, &context,
7093                                   &defaultspec, 0, &rms_sts, &lff_flags)))
7094         {
7095         char *string;
7096         char *c;
7097
7098         string = PerlMem_malloc(resultspec.dsc$w_length+1);
7099         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7100         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7101         string[resultspec.dsc$w_length] = '\0';
7102         if (NULL == had_version)
7103             *(strrchr(string, ';')) = '\0';
7104         if ((!had_directory) && (had_device == NULL))
7105             {
7106             if (NULL == (devdir = strrchr(string, ']')))
7107                 devdir = strrchr(string, '>');
7108             strcpy(string, devdir + 1);
7109             }
7110         /*
7111          * Be consistent with what the C RTL has already done to the rest of
7112          * the argv items and lowercase all of these names.
7113          */
7114         if (!decc_efs_case_preserve) {
7115             for (c = string; *c; ++c)
7116             if (isupper(*c))
7117                 *c = tolower(*c);
7118         }
7119         if (isunix) trim_unixpath(string,item,1);
7120         add_item(head, tail, string, count);
7121         ++expcount;
7122     }
7123     PerlMem_free(vmsspec);
7124     if (sts != RMS$_NMF)
7125         {
7126         set_vaxc_errno(sts);
7127         switch (sts)
7128             {
7129             case RMS$_FNF: case RMS$_DNF:
7130                 set_errno(ENOENT); break;
7131             case RMS$_DIR:
7132                 set_errno(ENOTDIR); break;
7133             case RMS$_DEV:
7134                 set_errno(ENODEV); break;
7135             case RMS$_FNM: case RMS$_SYN:
7136                 set_errno(EINVAL); break;
7137             case RMS$_PRV:
7138                 set_errno(EACCES); break;
7139             default:
7140                 _ckvmssts_noperl(sts);
7141             }
7142         }
7143     if (expcount == 0)
7144         add_item(head, tail, item, count);
7145     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7146     _ckvmssts_noperl(lib$find_file_end(&context));
7147 }
7148
7149 static int child_st[2];/* Event Flag set when child process completes   */
7150
7151 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
7152
7153 static unsigned long int exit_handler(int *status)
7154 {
7155 short iosb[4];
7156
7157     if (0 == child_st[0])
7158         {
7159 #ifdef ARGPROC_DEBUG
7160         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7161 #endif
7162         fflush(stdout);     /* Have to flush pipe for binary data to    */
7163                             /* terminate properly -- <tp@mccall.com>    */
7164         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7165         sys$dassgn(child_chan);
7166         fclose(stdout);
7167         sys$synch(0, child_st);
7168         }
7169     return(1);
7170 }
7171
7172 static void sig_child(int chan)
7173 {
7174 #ifdef ARGPROC_DEBUG
7175     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7176 #endif
7177     if (child_st[0] == 0)
7178         child_st[0] = 1;
7179 }
7180
7181 static struct exit_control_block exit_block =
7182     {
7183     0,
7184     exit_handler,
7185     1,
7186     &exit_block.exit_status,
7187     0
7188     };
7189
7190 static void
7191 pipe_and_fork(pTHX_ char **cmargv)
7192 {
7193     PerlIO *fp;
7194     struct dsc$descriptor_s *vmscmd;
7195     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7196     int sts, j, l, ismcr, quote, tquote = 0;
7197
7198     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
7199     vms_execfree(vmscmd);
7200
7201     j = l = 0;
7202     p = subcmd;
7203     q = cmargv[0];
7204     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
7205               && toupper(*(q+2)) == 'R' && !*(q+3);
7206
7207     while (q && l < MAX_DCL_LINE_LENGTH) {
7208         if (!*q) {
7209             if (j > 0 && quote) {
7210                 *p++ = '"';
7211                 l++;
7212             }
7213             q = cmargv[++j];
7214             if (q) {
7215                 if (ismcr && j > 1) quote = 1;
7216                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
7217                 *p++ = ' ';
7218                 l++;
7219                 if (quote || tquote) {
7220                     *p++ = '"';
7221                     l++;
7222                 }
7223             }
7224         } else {
7225             if ((quote||tquote) && *q == '"') {
7226                 *p++ = '"';
7227                 l++;
7228             }
7229             *p++ = *q++;
7230             l++;
7231         }
7232     }
7233     *p = '\0';
7234
7235     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7236     if (fp == Nullfp) {
7237         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7238     }
7239 }
7240
7241 static int background_process(pTHX_ int argc, char **argv)
7242 {
7243 char command[MAX_DCL_SYMBOL + 1] = "$";
7244 $DESCRIPTOR(value, "");
7245 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7246 static $DESCRIPTOR(null, "NLA0:");
7247 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7248 char pidstring[80];
7249 $DESCRIPTOR(pidstr, "");
7250 int pid;
7251 unsigned long int flags = 17, one = 1, retsts;
7252 int len;
7253
7254     strcat(command, argv[0]);
7255     len = strlen(command);
7256     while (--argc && (len < MAX_DCL_SYMBOL))
7257         {
7258         strcat(command, " \"");
7259         strcat(command, *(++argv));
7260         strcat(command, "\"");
7261         len = strlen(command);
7262         }
7263     value.dsc$a_pointer = command;
7264     value.dsc$w_length = strlen(value.dsc$a_pointer);
7265     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7266     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7267     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7268         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7269     }
7270     else {
7271         _ckvmssts_noperl(retsts);
7272     }
7273 #ifdef ARGPROC_DEBUG
7274     PerlIO_printf(Perl_debug_log, "%s\n", command);
7275 #endif
7276     sprintf(pidstring, "%08X", pid);
7277     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7278     pidstr.dsc$a_pointer = pidstring;
7279     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7280     lib$set_symbol(&pidsymbol, &pidstr);
7281     return(SS$_NORMAL);
7282 }
7283 /*}}}*/
7284 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7285
7286
7287 /* OS-specific initialization at image activation (not thread startup) */
7288 /* Older VAXC header files lack these constants */
7289 #ifndef JPI$_RIGHTS_SIZE
7290 #  define JPI$_RIGHTS_SIZE 817
7291 #endif
7292 #ifndef KGB$M_SUBSYSTEM
7293 #  define KGB$M_SUBSYSTEM 0x8
7294 #endif
7295
7296 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7297
7298 /*{{{void vms_image_init(int *, char ***)*/
7299 void
7300 vms_image_init(int *argcp, char ***argvp)
7301 {
7302   char eqv[LNM$C_NAMLENGTH+1] = "";
7303   unsigned int len, tabct = 8, tabidx = 0;
7304   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7305   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7306   unsigned short int dummy, rlen;
7307   struct dsc$descriptor_s **tabvec;
7308 #if defined(PERL_IMPLICIT_CONTEXT)
7309   pTHX = NULL;
7310 #endif
7311   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
7312                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
7313                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7314                                  {          0,                0,    0,      0} };
7315
7316 #ifdef KILL_BY_SIGPRC
7317     Perl_csighandler_init();
7318 #endif
7319
7320   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7321   _ckvmssts_noperl(iosb[0]);
7322   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7323     if (iprv[i]) {           /* Running image installed with privs? */
7324       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
7325       will_taint = TRUE;
7326       break;
7327     }
7328   }
7329   /* Rights identifiers might trigger tainting as well. */
7330   if (!will_taint && (rlen || rsz)) {
7331     while (rlen < rsz) {
7332       /* We didn't get all the identifiers on the first pass.  Allocate a
7333        * buffer much larger than $GETJPI wants (rsz is size in bytes that
7334        * were needed to hold all identifiers at time of last call; we'll
7335        * allocate that many unsigned long ints), and go back and get 'em.
7336        * If it gave us less than it wanted to despite ample buffer space,
7337        * something's broken.  Is your system missing a system identifier?
7338        */
7339       if (rsz <= jpilist[1].buflen) {
7340          /* Perl_croak accvios when used this early in startup. */
7341          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7342                          rsz, (unsigned long) jpilist[1].buflen,
7343                          "Check your rights database for corruption.\n");
7344          exit(SS$_ABORT);
7345       }
7346       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7347       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7348       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7349       jpilist[1].buflen = rsz * sizeof(unsigned long int);
7350       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7351       _ckvmssts_noperl(iosb[0]);
7352     }
7353     mask = jpilist[1].bufadr;
7354     /* Check attribute flags for each identifier (2nd longword); protected
7355      * subsystem identifiers trigger tainting.
7356      */
7357     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7358       if (mask[i] & KGB$M_SUBSYSTEM) {
7359         will_taint = TRUE;
7360         break;
7361       }
7362     }
7363     if (mask != rlst) PerlMem_free(mask);
7364   }
7365
7366   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7367    * logical, some versions of the CRTL will add a phanthom /000000/
7368    * directory.  This needs to be removed.
7369    */
7370   if (decc_filename_unix_report) {
7371   char * zeros;
7372   int ulen;
7373     ulen = strlen(argvp[0][0]);
7374     if (ulen > 7) {
7375       zeros = strstr(argvp[0][0], "/000000/");
7376       if (zeros != NULL) {
7377         int mlen;
7378         mlen = ulen - (zeros - argvp[0][0]) - 7;
7379         memmove(zeros, &zeros[7], mlen);
7380         ulen = ulen - 7;
7381         argvp[0][0][ulen] = '\0';
7382       }
7383     }
7384     /* It also may have a trailing dot that needs to be removed otherwise
7385      * it will be converted to VMS mode incorrectly.
7386      */
7387     ulen--;
7388     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7389       argvp[0][0][ulen] = '\0';
7390   }
7391
7392   /* We need to use this hack to tell Perl it should run with tainting,
7393    * since its tainting flag may be part of the PL_curinterp struct, which
7394    * hasn't been allocated when vms_image_init() is called.
7395    */
7396   if (will_taint) {
7397     char **newargv, **oldargv;
7398     oldargv = *argvp;
7399     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7400     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7401     newargv[0] = oldargv[0];
7402     newargv[1] = PerlMem_malloc(3 * sizeof(char));
7403     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7404     strcpy(newargv[1], "-T");
7405     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7406     (*argcp)++;
7407     newargv[*argcp] = NULL;
7408     /* We orphan the old argv, since we don't know where it's come from,
7409      * so we don't know how to free it.
7410      */
7411     *argvp = newargv;
7412   }
7413   else {  /* Did user explicitly request tainting? */
7414     int i;
7415     char *cp, **av = *argvp;
7416     for (i = 1; i < *argcp; i++) {
7417       if (*av[i] != '-') break;
7418       for (cp = av[i]+1; *cp; cp++) {
7419         if (*cp == 'T') { will_taint = 1; break; }
7420         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7421                   strchr("DFIiMmx",*cp)) break;
7422       }
7423       if (will_taint) break;
7424     }
7425   }
7426
7427   for (tabidx = 0;
7428        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7429        tabidx++) {
7430     if (!tabidx) {
7431       tabvec = (struct dsc$descriptor_s **)
7432             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7433       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7434     }
7435     else if (tabidx >= tabct) {
7436       tabct += 8;
7437       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7438       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7439     }
7440     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7441     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7442     tabvec[tabidx]->dsc$w_length  = 0;
7443     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
7444     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
7445     tabvec[tabidx]->dsc$a_pointer = NULL;
7446     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7447   }
7448   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7449
7450   getredirection(argcp,argvp);
7451 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7452   {
7453 # include <reentrancy.h>
7454   decc$set_reentrancy(C$C_MULTITHREAD);
7455   }
7456 #endif
7457   return;
7458 }
7459 /*}}}*/
7460
7461
7462 /* trim_unixpath()
7463  * Trim Unix-style prefix off filespec, so it looks like what a shell
7464  * glob expansion would return (i.e. from specified prefix on, not
7465  * full path).  Note that returned filespec is Unix-style, regardless
7466  * of whether input filespec was VMS-style or Unix-style.
7467  *
7468  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7469  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
7470  * vector of options; at present, only bit 0 is used, and if set tells
7471  * trim unixpath to try the current default directory as a prefix when
7472  * presented with a possibly ambiguous ... wildcard.
7473  *
7474  * Returns !=0 on success, with trimmed filespec replacing contents of
7475  * fspec, and 0 on failure, with contents of fpsec unchanged.
7476  */
7477 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7478 int
7479 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7480 {
7481   char *unixified, *unixwild,
7482        *template, *base, *end, *cp1, *cp2;
7483   register int tmplen, reslen = 0, dirs = 0;
7484
7485   unixwild = PerlMem_malloc(VMS_MAXRSS);
7486   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
7487   if (!wildspec || !fspec) return 0;
7488   template = unixwild;
7489   if (strpbrk(wildspec,"]>:") != NULL) {
7490     if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7491         PerlMem_free(unixwild);
7492         return 0;
7493     }
7494   }
7495   else {
7496     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7497     unixwild[VMS_MAXRSS-1] = 0;
7498   }
7499   unixified = PerlMem_malloc(VMS_MAXRSS);
7500   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
7501   if (strpbrk(fspec,"]>:") != NULL) {
7502     if (do_tounixspec(fspec,unixified,0) == NULL) {
7503         PerlMem_free(unixwild);
7504         PerlMem_free(unixified);
7505         return 0;
7506     }
7507     else base = unixified;
7508     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7509      * check to see that final result fits into (isn't longer than) fspec */
7510     reslen = strlen(fspec);
7511   }
7512   else base = fspec;
7513
7514   /* No prefix or absolute path on wildcard, so nothing to remove */
7515   if (!*template || *template == '/') {
7516     PerlMem_free(unixwild);
7517     if (base == fspec) {
7518         PerlMem_free(unixified);
7519         return 1;
7520     }
7521     tmplen = strlen(unixified);
7522     if (tmplen > reslen) {
7523         PerlMem_free(unixified);
7524         return 0;  /* not enough space */
7525     }
7526     /* Copy unixified resultant, including trailing NUL */
7527     memmove(fspec,unixified,tmplen+1);
7528     PerlMem_free(unixified);
7529     return 1;
7530   }
7531
7532   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
7533   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7534     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7535     for (cp1 = end ;cp1 >= base; cp1--)
7536       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7537         { cp1++; break; }
7538     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7539     PerlMem_free(unixified);
7540     PerlMem_free(unixwild);
7541     return 1;
7542   }
7543   else {
7544     char *tpl, *lcres;
7545     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7546     int ells = 1, totells, segdirs, match;
7547     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7548                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7549
7550     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7551     totells = ells;
7552     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7553     tpl = PerlMem_malloc(VMS_MAXRSS);
7554     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
7555     if (ellipsis == template && opts & 1) {
7556       /* Template begins with an ellipsis.  Since we can't tell how many
7557        * directory names at the front of the resultant to keep for an
7558        * arbitrary starting point, we arbitrarily choose the current
7559        * default directory as a starting point.  If it's there as a prefix,
7560        * clip it off.  If not, fall through and act as if the leading
7561        * ellipsis weren't there (i.e. return shortest possible path that
7562        * could match template).
7563        */
7564       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7565           PerlMem_free(tpl);
7566           PerlMem_free(unixified);
7567           PerlMem_free(unixwild);
7568           return 0;
7569       }
7570       if (!decc_efs_case_preserve) {
7571         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7572           if (_tolower(*cp1) != _tolower(*cp2)) break;
7573       }
7574       segdirs = dirs - totells;  /* Min # of dirs we must have left */
7575       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7576       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7577         memmove(fspec,cp2+1,end - cp2);
7578         PerlMem_free(tpl);
7579         PerlMem_free(unixified);
7580         PerlMem_free(unixwild);
7581         return 1;
7582       }
7583     }
7584     /* First off, back up over constant elements at end of path */
7585     if (dirs) {
7586       for (front = end ; front >= base; front--)
7587          if (*front == '/' && !dirs--) { front++; break; }
7588     }
7589     lcres = PerlMem_malloc(VMS_MAXRSS);
7590     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
7591     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7592          cp1++,cp2++) {
7593             if (!decc_efs_case_preserve) {
7594                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
7595             }
7596             else {
7597                 *cp2 = *cp1;
7598             }
7599     }
7600     if (cp1 != '\0') {
7601         PerlMem_free(tpl);
7602         PerlMem_free(unixified);
7603         PerlMem_free(unixwild);
7604         PerlMem_free(lcres);
7605         return 0;  /* Path too long. */
7606     }
7607     lcend = cp2;
7608     *cp2 = '\0';  /* Pick up with memcpy later */
7609     lcfront = lcres + (front - base);
7610     /* Now skip over each ellipsis and try to match the path in front of it. */
7611     while (ells--) {
7612       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7613         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
7614             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
7615       if (cp1 < template) break; /* template started with an ellipsis */
7616       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7617         ellipsis = cp1; continue;
7618       }
7619       wilddsc.dsc$a_pointer = tpl;
7620       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7621       nextell = cp1;
7622       for (segdirs = 0, cp2 = tpl;
7623            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7624            cp1++, cp2++) {
7625          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7626          else {
7627             if (!decc_efs_case_preserve) {
7628               *cp2 = _tolower(*cp1);  /* else lowercase for match */
7629             }
7630             else {
7631               *cp2 = *cp1;  /* else preserve case for match */
7632             }
7633          }
7634          if (*cp2 == '/') segdirs++;
7635       }
7636       if (cp1 != ellipsis - 1) {
7637           PerlMem_free(tpl);
7638           PerlMem_free(unixified);
7639           PerlMem_free(unixwild);
7640           PerlMem_free(lcres);
7641           return 0; /* Path too long */
7642       }
7643       /* Back up at least as many dirs as in template before matching */
7644       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7645         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7646       for (match = 0; cp1 > lcres;) {
7647         resdsc.dsc$a_pointer = cp1;
7648         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7649           match++;
7650           if (match == 1) lcfront = cp1;
7651         }
7652         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7653       }
7654       if (!match) {
7655         PerlMem_free(tpl);
7656         PerlMem_free(unixified);
7657         PerlMem_free(unixwild);
7658         PerlMem_free(lcres);
7659         return 0;  /* Can't find prefix ??? */
7660       }
7661       if (match > 1 && opts & 1) {
7662         /* This ... wildcard could cover more than one set of dirs (i.e.
7663          * a set of similar dir names is repeated).  If the template
7664          * contains more than 1 ..., upstream elements could resolve the
7665          * ambiguity, but it's not worth a full backtracking setup here.
7666          * As a quick heuristic, clip off the current default directory
7667          * if it's present to find the trimmed spec, else use the
7668          * shortest string that this ... could cover.
7669          */
7670         char def[NAM$C_MAXRSS+1], *st;
7671
7672         if (getcwd(def, sizeof def,0) == NULL) {
7673             Safefree(unixified);
7674             Safefree(unixwild);
7675             Safefree(lcres);
7676             Safefree(tpl);
7677             return 0;
7678         }
7679         if (!decc_efs_case_preserve) {
7680           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7681             if (_tolower(*cp1) != _tolower(*cp2)) break;
7682         }
7683         segdirs = dirs - totells;  /* Min # of dirs we must have left */
7684         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7685         if (*cp1 == '\0' && *cp2 == '/') {
7686           memmove(fspec,cp2+1,end - cp2);
7687           PerlMem_free(tpl);
7688           PerlMem_free(unixified);
7689           PerlMem_free(unixwild);
7690           PerlMem_free(lcres);
7691           return 1;
7692         }
7693         /* Nope -- stick with lcfront from above and keep going. */
7694       }
7695     }
7696     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7697     PerlMem_free(tpl);
7698     PerlMem_free(unixified);
7699     PerlMem_free(unixwild);
7700     PerlMem_free(lcres);
7701     return 1;
7702     ellipsis = nextell;
7703   }
7704
7705 }  /* end of trim_unixpath() */
7706 /*}}}*/
7707
7708
7709 /*
7710  *  VMS readdir() routines.
7711  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7712  *
7713  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
7714  *  Minor modifications to original routines.
7715  */
7716
7717 /* readdir may have been redefined by reentr.h, so make sure we get
7718  * the local version for what we do here.
7719  */
7720 #ifdef readdir
7721 # undef readdir
7722 #endif
7723 #if !defined(PERL_IMPLICIT_CONTEXT)
7724 # define readdir Perl_readdir
7725 #else
7726 # define readdir(a) Perl_readdir(aTHX_ a)
7727 #endif
7728
7729     /* Number of elements in vms_versions array */
7730 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
7731
7732 /*
7733  *  Open a directory, return a handle for later use.
7734  */
7735 /*{{{ DIR *opendir(char*name) */
7736 DIR *
7737 Perl_opendir(pTHX_ const char *name)
7738 {
7739     DIR *dd;
7740     char *dir;
7741     Stat_t sb;
7742     int unix_flag;
7743
7744     unix_flag = 0;
7745     if (decc_efs_charset) {
7746         unix_flag = is_unix_filespec(name);
7747     }
7748
7749     Newx(dir, VMS_MAXRSS, char);
7750     if (do_tovmspath(name,dir,0) == NULL) {
7751       Safefree(dir);
7752       return NULL;
7753     }
7754     /* Check access before stat; otherwise stat does not
7755      * accurately report whether it's a directory.
7756      */
7757     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
7758       /* cando_by_name has already set errno */
7759       Safefree(dir);
7760       return NULL;
7761     }
7762     if (flex_stat(dir,&sb) == -1) return NULL;
7763     if (!S_ISDIR(sb.st_mode)) {
7764       Safefree(dir);
7765       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
7766       return NULL;
7767     }
7768     /* Get memory for the handle, and the pattern. */
7769     Newx(dd,1,DIR);
7770     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7771
7772     /* Fill in the fields; mainly playing with the descriptor. */
7773     sprintf(dd->pattern, "%s*.*",dir);
7774     Safefree(dir);
7775     dd->context = 0;
7776     dd->count = 0;
7777     dd->flags = 0;
7778     if (unix_flag)
7779         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
7780     dd->pat.dsc$a_pointer = dd->pattern;
7781     dd->pat.dsc$w_length = strlen(dd->pattern);
7782     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7783     dd->pat.dsc$b_class = DSC$K_CLASS_S;
7784 #if defined(USE_ITHREADS)
7785     Newx(dd->mutex,1,perl_mutex);
7786     MUTEX_INIT( (perl_mutex *) dd->mutex );
7787 #else
7788     dd->mutex = NULL;
7789 #endif
7790
7791     return dd;
7792 }  /* end of opendir() */
7793 /*}}}*/
7794
7795 /*
7796  *  Set the flag to indicate we want versions or not.
7797  */
7798 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7799 void
7800 vmsreaddirversions(DIR *dd, int flag)
7801 {
7802     if (flag)
7803         dd->flags |= PERL_VMSDIR_M_VERSIONS;
7804     else
7805         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
7806 }
7807 /*}}}*/
7808
7809 /*
7810  *  Free up an opened directory.
7811  */
7812 /*{{{ void closedir(DIR *dd)*/
7813 void
7814 Perl_closedir(DIR *dd)
7815 {
7816     int sts;
7817
7818     sts = lib$find_file_end(&dd->context);
7819     Safefree(dd->pattern);
7820 #if defined(USE_ITHREADS)
7821     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7822     Safefree(dd->mutex);
7823 #endif
7824     Safefree(dd);
7825 }
7826 /*}}}*/
7827
7828 /*
7829  *  Collect all the version numbers for the current file.
7830  */
7831 static void
7832 collectversions(pTHX_ DIR *dd)
7833 {
7834     struct dsc$descriptor_s     pat;
7835     struct dsc$descriptor_s     res;
7836     struct dirent *e;
7837     char *p, *text, *buff;
7838     int i;
7839     unsigned long context, tmpsts;
7840
7841     /* Convenient shorthand. */
7842     e = &dd->entry;
7843
7844     /* Add the version wildcard, ignoring the "*.*" put on before */
7845     i = strlen(dd->pattern);
7846     Newx(text,i + e->d_namlen + 3,char);
7847     strcpy(text, dd->pattern);
7848     sprintf(&text[i - 3], "%s;*", e->d_name);
7849
7850     /* Set up the pattern descriptor. */
7851     pat.dsc$a_pointer = text;
7852     pat.dsc$w_length = i + e->d_namlen - 1;
7853     pat.dsc$b_dtype = DSC$K_DTYPE_T;
7854     pat.dsc$b_class = DSC$K_CLASS_S;
7855
7856     /* Set up result descriptor. */
7857     Newx(buff, VMS_MAXRSS, char);
7858     res.dsc$a_pointer = buff;
7859     res.dsc$w_length = VMS_MAXRSS - 1;
7860     res.dsc$b_dtype = DSC$K_DTYPE_T;
7861     res.dsc$b_class = DSC$K_CLASS_S;
7862
7863     /* Read files, collecting versions. */
7864     for (context = 0, e->vms_verscount = 0;
7865          e->vms_verscount < VERSIZE(e);
7866          e->vms_verscount++) {
7867         unsigned long rsts;
7868         unsigned long flags = 0;
7869
7870 #ifdef VMS_LONGNAME_SUPPORT
7871         flags = LIB$M_FIL_LONG_NAMES;
7872 #endif
7873         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
7874         if (tmpsts == RMS$_NMF || context == 0) break;
7875         _ckvmssts(tmpsts);
7876         buff[VMS_MAXRSS - 1] = '\0';
7877         if ((p = strchr(buff, ';')))
7878             e->vms_versions[e->vms_verscount] = atoi(p + 1);
7879         else
7880             e->vms_versions[e->vms_verscount] = -1;
7881     }
7882
7883     _ckvmssts(lib$find_file_end(&context));
7884     Safefree(text);
7885     Safefree(buff);
7886
7887 }  /* end of collectversions() */
7888
7889 /*
7890  *  Read the next entry from the directory.
7891  */
7892 /*{{{ struct dirent *readdir(DIR *dd)*/
7893 struct dirent *
7894 Perl_readdir(pTHX_ DIR *dd)
7895 {
7896     struct dsc$descriptor_s     res;
7897     char *p, *buff;
7898     unsigned long int tmpsts;
7899     unsigned long rsts;
7900     unsigned long flags = 0;
7901     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7902     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7903
7904     /* Set up result descriptor, and get next file. */
7905     Newx(buff, VMS_MAXRSS, char);
7906     res.dsc$a_pointer = buff;
7907     res.dsc$w_length = VMS_MAXRSS - 1;
7908     res.dsc$b_dtype = DSC$K_DTYPE_T;
7909     res.dsc$b_class = DSC$K_CLASS_S;
7910
7911 #ifdef VMS_LONGNAME_SUPPORT
7912     flags = LIB$M_FIL_LONG_NAMES;
7913 #endif
7914
7915     tmpsts = lib$find_file
7916         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
7917     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
7918     if (!(tmpsts & 1)) {
7919       set_vaxc_errno(tmpsts);
7920       switch (tmpsts) {
7921         case RMS$_PRV:
7922           set_errno(EACCES); break;
7923         case RMS$_DEV:
7924           set_errno(ENODEV); break;
7925         case RMS$_DIR:
7926           set_errno(ENOTDIR); break;
7927         case RMS$_FNF: case RMS$_DNF:
7928           set_errno(ENOENT); break;
7929         default:
7930           set_errno(EVMSERR);
7931       }
7932       Safefree(buff);
7933       return NULL;
7934     }
7935     dd->count++;
7936     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
7937     if (!decc_efs_case_preserve) {
7938       buff[VMS_MAXRSS - 1] = '\0';
7939       for (p = buff; *p; p++) *p = _tolower(*p);
7940     }
7941     else {
7942       /* we don't want to force to lowercase, just null terminate */
7943       buff[res.dsc$w_length] = '\0';
7944     }
7945     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
7946     *p = '\0';
7947
7948     /* Skip any directory component and just copy the name. */
7949     sts = vms_split_path
7950        (aTHX_ buff,
7951         &v_spec,
7952         &v_len,
7953         &r_spec,
7954         &r_len,
7955         &d_spec,
7956         &d_len,
7957         &n_spec,
7958         &n_len,
7959         &e_spec,
7960         &e_len,
7961         &vs_spec,
7962         &vs_len);
7963
7964     /* Drop NULL extensions on UNIX file specification */
7965     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
7966         (e_len == 1) && decc_readdir_dropdotnotype)) {
7967         e_len = 0;
7968         e_spec[0] = '\0';
7969     }
7970
7971     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
7972     dd->entry.d_name[n_len + e_len] = '\0';
7973     dd->entry.d_namlen = strlen(dd->entry.d_name);
7974
7975     /* Convert the filename to UNIX format if needed */
7976     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
7977
7978         /* Translate the encoded characters. */
7979         /* Fixme: unicode handling could result in embedded 0 characters */
7980         if (strchr(dd->entry.d_name, '^') != NULL) {
7981             char new_name[256];
7982             char * q;
7983             int cnt;
7984             p = dd->entry.d_name;
7985             q = new_name;
7986             while (*p != 0) {
7987                 int x, y;
7988                 x = copy_expand_vms_filename_escape(q, p, &y);
7989                 p += x;
7990                 q += y;
7991                 /* fix-me */
7992                 /* if y > 1, then this is a wide file specification */
7993                 /* Wide file specifications need to be passed in Perl */
7994                 /* counted strings apparently with a unicode flag */
7995             }
7996             *q = 0;
7997             strcpy(dd->entry.d_name, new_name);
7998         }
7999     }
8000
8001     dd->entry.vms_verscount = 0;
8002     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8003     Safefree(buff);
8004     return &dd->entry;
8005
8006 }  /* end of readdir() */
8007 /*}}}*/
8008
8009 /*
8010  *  Read the next entry from the directory -- thread-safe version.
8011  */
8012 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8013 int
8014 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8015 {
8016     int retval;
8017
8018     MUTEX_LOCK( (perl_mutex *) dd->mutex );
8019
8020     entry = readdir(dd);
8021     *result = entry;
8022     retval = ( *result == NULL ? errno : 0 );
8023
8024     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8025
8026     return retval;
8027
8028 }  /* end of readdir_r() */
8029 /*}}}*/
8030
8031 /*
8032  *  Return something that can be used in a seekdir later.
8033  */
8034 /*{{{ long telldir(DIR *dd)*/
8035 long
8036 Perl_telldir(DIR *dd)
8037 {
8038     return dd->count;
8039 }
8040 /*}}}*/
8041
8042 /*
8043  *  Return to a spot where we used to be.  Brute force.
8044  */
8045 /*{{{ void seekdir(DIR *dd,long count)*/
8046 void
8047 Perl_seekdir(pTHX_ DIR *dd, long count)
8048 {
8049     int old_flags;
8050
8051     /* If we haven't done anything yet... */
8052     if (dd->count == 0)
8053         return;
8054
8055     /* Remember some state, and clear it. */
8056     old_flags = dd->flags;
8057     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8058     _ckvmssts(lib$find_file_end(&dd->context));
8059     dd->context = 0;
8060
8061     /* The increment is in readdir(). */
8062     for (dd->count = 0; dd->count < count; )
8063         readdir(dd);
8064
8065     dd->flags = old_flags;
8066
8067 }  /* end of seekdir() */
8068 /*}}}*/
8069
8070 /* VMS subprocess management
8071  *
8072  * my_vfork() - just a vfork(), after setting a flag to record that
8073  * the current script is trying a Unix-style fork/exec.
8074  *
8075  * vms_do_aexec() and vms_do_exec() are called in response to the
8076  * perl 'exec' function.  If this follows a vfork call, then they
8077  * call out the regular perl routines in doio.c which do an
8078  * execvp (for those who really want to try this under VMS).
8079  * Otherwise, they do exactly what the perl docs say exec should
8080  * do - terminate the current script and invoke a new command
8081  * (See below for notes on command syntax.)
8082  *
8083  * do_aspawn() and do_spawn() implement the VMS side of the perl
8084  * 'system' function.
8085  *
8086  * Note on command arguments to perl 'exec' and 'system': When handled
8087  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8088  * are concatenated to form a DCL command string.  If the first arg
8089  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8090  * the command string is handed off to DCL directly.  Otherwise,
8091  * the first token of the command is taken as the filespec of an image
8092  * to run.  The filespec is expanded using a default type of '.EXE' and
8093  * the process defaults for device, directory, etc., and if found, the resultant
8094  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8095  * the command string as parameters.  This is perhaps a bit complicated,
8096  * but I hope it will form a happy medium between what VMS folks expect
8097  * from lib$spawn and what Unix folks expect from exec.
8098  */
8099
8100 static int vfork_called;
8101
8102 /*{{{int my_vfork()*/
8103 int
8104 my_vfork()
8105 {
8106   vfork_called++;
8107   return vfork();
8108 }
8109 /*}}}*/
8110
8111
8112 static void
8113 vms_execfree(struct dsc$descriptor_s *vmscmd)
8114 {
8115   if (vmscmd) {
8116       if (vmscmd->dsc$a_pointer) {
8117           PerlMem_free(vmscmd->dsc$a_pointer);
8118       }
8119       PerlMem_free(vmscmd);
8120   }
8121 }
8122
8123 static char *
8124 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8125 {
8126   char *junk, *tmps = Nullch;
8127   register size_t cmdlen = 0;
8128   size_t rlen;
8129   register SV **idx;
8130   STRLEN n_a;
8131
8132   idx = mark;
8133   if (really) {
8134     tmps = SvPV(really,rlen);
8135     if (*tmps) {
8136       cmdlen += rlen + 1;
8137       idx++;
8138     }
8139   }
8140
8141   for (idx++; idx <= sp; idx++) {
8142     if (*idx) {
8143       junk = SvPVx(*idx,rlen);
8144       cmdlen += rlen ? rlen + 1 : 0;
8145     }
8146   }
8147   Newx(PL_Cmd, cmdlen+1, char);
8148
8149   if (tmps && *tmps) {
8150     strcpy(PL_Cmd,tmps);
8151     mark++;
8152   }
8153   else *PL_Cmd = '\0';
8154   while (++mark <= sp) {
8155     if (*mark) {
8156       char *s = SvPVx(*mark,n_a);
8157       if (!*s) continue;
8158       if (*PL_Cmd) strcat(PL_Cmd," ");
8159       strcat(PL_Cmd,s);
8160     }
8161   }
8162   return PL_Cmd;
8163
8164 }  /* end of setup_argstr() */
8165
8166
8167 static unsigned long int
8168 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8169                    struct dsc$descriptor_s **pvmscmd)
8170 {
8171   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8172   char image_name[NAM$C_MAXRSS+1];
8173   char image_argv[NAM$C_MAXRSS+1];
8174   $DESCRIPTOR(defdsc,".EXE");
8175   $DESCRIPTOR(defdsc2,".");
8176   $DESCRIPTOR(resdsc,resspec);
8177   struct dsc$descriptor_s *vmscmd;
8178   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8179   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8180   register char *s, *rest, *cp, *wordbreak;
8181   char * cmd;
8182   int cmdlen;
8183   register int isdcl;
8184
8185   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8186   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8187
8188   /* Make a copy for modification */
8189   cmdlen = strlen(incmd);
8190   cmd = PerlMem_malloc(cmdlen+1);
8191   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8192   strncpy(cmd, incmd, cmdlen);
8193   cmd[cmdlen] = 0;
8194   image_name[0] = 0;
8195   image_argv[0] = 0;
8196
8197   vmscmd->dsc$a_pointer = NULL;
8198   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
8199   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
8200   vmscmd->dsc$w_length = 0;
8201   if (pvmscmd) *pvmscmd = vmscmd;
8202
8203   if (suggest_quote) *suggest_quote = 0;
8204
8205   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8206     PerlMem_free(cmd);
8207     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
8208   }
8209
8210   s = cmd;
8211
8212   while (*s && isspace(*s)) s++;
8213
8214   if (*s == '@' || *s == '$') {
8215     vmsspec[0] = *s;  rest = s + 1;
8216     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8217   }
8218   else { cp = vmsspec; rest = s; }
8219   if (*rest == '.' || *rest == '/') {
8220     char *cp2;
8221     for (cp2 = resspec;
8222          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8223          rest++, cp2++) *cp2 = *rest;
8224     *cp2 = '\0';
8225     if (do_tovmsspec(resspec,cp,0)) {
8226       s = vmsspec;
8227       if (*rest) {
8228         for (cp2 = vmsspec + strlen(vmsspec);
8229              *rest && cp2 - vmsspec < sizeof vmsspec;
8230              rest++, cp2++) *cp2 = *rest;
8231         *cp2 = '\0';
8232       }
8233     }
8234   }
8235   /* Intuit whether verb (first word of cmd) is a DCL command:
8236    *   - if first nonspace char is '@', it's a DCL indirection
8237    * otherwise
8238    *   - if verb contains a filespec separator, it's not a DCL command
8239    *   - if it doesn't, caller tells us whether to default to a DCL
8240    *     command, or to a local image unless told it's DCL (by leading '$')
8241    */
8242   if (*s == '@') {
8243       isdcl = 1;
8244       if (suggest_quote) *suggest_quote = 1;
8245   } else {
8246     register char *filespec = strpbrk(s,":<[.;");
8247     rest = wordbreak = strpbrk(s," \"\t/");
8248     if (!wordbreak) wordbreak = s + strlen(s);
8249     if (*s == '$') check_img = 0;
8250     if (filespec && (filespec < wordbreak)) isdcl = 0;
8251     else isdcl = !check_img;
8252   }
8253
8254   if (!isdcl) {
8255     int rsts;
8256     imgdsc.dsc$a_pointer = s;
8257     imgdsc.dsc$w_length = wordbreak - s;
8258     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8259     if (!(retsts&1)) {
8260         _ckvmssts(lib$find_file_end(&cxt));
8261         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8262       if (!(retsts & 1) && *s == '$') {
8263         _ckvmssts(lib$find_file_end(&cxt));
8264         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8265         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8266         if (!(retsts&1)) {
8267           _ckvmssts(lib$find_file_end(&cxt));
8268           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8269         }
8270       }
8271     }
8272     _ckvmssts(lib$find_file_end(&cxt));
8273
8274     if (retsts & 1) {
8275       FILE *fp;
8276       s = resspec;
8277       while (*s && !isspace(*s)) s++;
8278       *s = '\0';
8279
8280       /* check that it's really not DCL with no file extension */
8281       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8282       if (fp) {
8283         char b[256] = {0,0,0,0};
8284         read(fileno(fp), b, 256);
8285         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
8286         if (isdcl) {
8287           int shebang_len;
8288
8289           /* Check for script */
8290           shebang_len = 0;
8291           if ((b[0] == '#') && (b[1] == '!'))
8292              shebang_len = 2;
8293 #ifdef ALTERNATE_SHEBANG
8294           else {
8295             shebang_len = strlen(ALTERNATE_SHEBANG);
8296             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
8297               char * perlstr;
8298                 perlstr = strstr("perl",b);
8299                 if (perlstr == NULL)
8300                   shebang_len = 0;
8301             }
8302             else
8303               shebang_len = 0;
8304           }
8305 #endif
8306
8307           if (shebang_len > 0) {
8308           int i;
8309           int j;
8310           char tmpspec[NAM$C_MAXRSS + 1];
8311
8312             i = shebang_len;
8313              /* Image is following after white space */
8314             /*--------------------------------------*/
8315             while (isprint(b[i]) && isspace(b[i]))
8316                 i++;
8317
8318             j = 0;
8319             while (isprint(b[i]) && !isspace(b[i])) {
8320                 tmpspec[j++] = b[i++];
8321                 if (j >= NAM$C_MAXRSS)
8322                    break;
8323             }
8324             tmpspec[j] = '\0';
8325
8326              /* There may be some default parameters to the image */
8327             /*---------------------------------------------------*/
8328             j = 0;
8329             while (isprint(b[i])) {
8330                 image_argv[j++] = b[i++];
8331                 if (j >= NAM$C_MAXRSS)
8332                    break;
8333             }
8334             while ((j > 0) && !isprint(image_argv[j-1]))
8335                 j--;
8336             image_argv[j] = 0;
8337
8338             /* It will need to be converted to VMS format and validated */
8339             if (tmpspec[0] != '\0') {
8340               char * iname;
8341
8342                /* Try to find the exact program requested to be run */
8343               /*---------------------------------------------------*/
8344               iname = do_rmsexpand
8345                   (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8346               if (iname != NULL) {
8347                 if (cando_by_name_int
8348                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
8349                   /* MCR prefix needed */
8350                   isdcl = 0;
8351                 }
8352                 else {
8353                    /* Try again with a null type */
8354                   /*----------------------------*/
8355                   iname = do_rmsexpand
8356                     (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8357                   if (iname != NULL) {
8358                     if (cando_by_name_int
8359                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
8360                       /* MCR prefix needed */
8361                       isdcl = 0;
8362                     }
8363                   }
8364                 }
8365
8366                  /* Did we find the image to run the script? */
8367                 /*------------------------------------------*/
8368                 if (isdcl) {
8369                   char *tchr;
8370
8371                    /* Assume DCL or foreign command exists */
8372                   /*--------------------------------------*/
8373                   tchr = strrchr(tmpspec, '/');
8374                   if (tchr != NULL) {
8375                     tchr++;
8376                   }
8377                   else {
8378                     tchr = tmpspec;
8379                   }
8380                   strcpy(image_name, tchr);
8381                 }
8382               }
8383             }
8384           }
8385         }
8386         fclose(fp);
8387       }
8388       if (check_img && isdcl) return RMS$_FNF;
8389
8390       if (cando_by_name(S_IXUSR,0,resspec)) {
8391         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
8392         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
8393         if (!isdcl) {
8394             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8395             if (image_name[0] != 0) {
8396                 strcat(vmscmd->dsc$a_pointer, image_name);
8397                 strcat(vmscmd->dsc$a_pointer, " ");
8398             }
8399         } else if (image_name[0] != 0) {
8400             strcpy(vmscmd->dsc$a_pointer, image_name);
8401             strcat(vmscmd->dsc$a_pointer, " ");
8402         } else {
8403             strcpy(vmscmd->dsc$a_pointer,"@");
8404         }
8405         if (suggest_quote) *suggest_quote = 1;
8406
8407         /* If there is an image name, use original command */
8408         if (image_name[0] == 0)
8409             strcat(vmscmd->dsc$a_pointer,resspec);
8410         else {
8411             rest = cmd;
8412             while (*rest && isspace(*rest)) rest++;
8413         }
8414
8415         if (image_argv[0] != 0) {
8416           strcat(vmscmd->dsc$a_pointer,image_argv);
8417           strcat(vmscmd->dsc$a_pointer, " ");
8418         }
8419         if (rest) {
8420            int rest_len;
8421            int vmscmd_len;
8422
8423            rest_len = strlen(rest);
8424            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8425            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8426               strcat(vmscmd->dsc$a_pointer,rest);
8427            else
8428              retsts = CLI$_BUFOVF;
8429         }
8430         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8431         PerlMem_free(cmd);
8432         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8433       }
8434       else
8435         retsts = RMS$_PRV;
8436     }
8437   }
8438   /* It's either a DCL command or we couldn't find a suitable image */
8439   vmscmd->dsc$w_length = strlen(cmd);
8440
8441   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
8442   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
8443   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
8444
8445   PerlMem_free(cmd);
8446
8447   /* check if it's a symbol (for quoting purposes) */
8448   if (suggest_quote && !*suggest_quote) {
8449     int iss;
8450     char equiv[LNM$C_NAMLENGTH];
8451     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8452     eqvdsc.dsc$a_pointer = equiv;
8453
8454     iss = lib$get_symbol(vmscmd,&eqvdsc);
8455     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8456   }
8457   if (!(retsts & 1)) {
8458     /* just hand off status values likely to be due to user error */
8459     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8460         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8461        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8462     else { _ckvmssts(retsts); }
8463   }
8464
8465   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8466
8467 }  /* end of setup_cmddsc() */
8468
8469
8470 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8471 bool
8472 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8473 {
8474 bool exec_sts;
8475 char * cmd;
8476
8477   if (sp > mark) {
8478     if (vfork_called) {           /* this follows a vfork - act Unixish */
8479       vfork_called--;
8480       if (vfork_called < 0) {
8481         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8482         vfork_called = 0;
8483       }
8484       else return do_aexec(really,mark,sp);
8485     }
8486                                            /* no vfork - act VMSish */
8487     cmd = setup_argstr(aTHX_ really,mark,sp);
8488     exec_sts = vms_do_exec(cmd);
8489     Safefree(cmd);  /* Clean up from setup_argstr() */
8490     return exec_sts;
8491   }
8492
8493   return FALSE;
8494 }  /* end of vms_do_aexec() */
8495 /*}}}*/
8496
8497 /* {{{bool vms_do_exec(char *cmd) */
8498 bool
8499 Perl_vms_do_exec(pTHX_ const char *cmd)
8500 {
8501   struct dsc$descriptor_s *vmscmd;
8502
8503   if (vfork_called) {             /* this follows a vfork - act Unixish */
8504     vfork_called--;
8505     if (vfork_called < 0) {
8506       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8507       vfork_called = 0;
8508     }
8509     else return do_exec(cmd);
8510   }
8511
8512   {                               /* no vfork - act VMSish */
8513     unsigned long int retsts;
8514
8515     TAINT_ENV();
8516     TAINT_PROPER("exec");
8517     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8518       retsts = lib$do_command(vmscmd);
8519
8520     switch (retsts) {
8521       case RMS$_FNF: case RMS$_DNF:
8522         set_errno(ENOENT); break;
8523       case RMS$_DIR:
8524         set_errno(ENOTDIR); break;
8525       case RMS$_DEV:
8526         set_errno(ENODEV); break;
8527       case RMS$_PRV:
8528         set_errno(EACCES); break;
8529       case RMS$_SYN:
8530         set_errno(EINVAL); break;
8531       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8532         set_errno(E2BIG); break;
8533       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8534         _ckvmssts(retsts); /* fall through */
8535       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8536         set_errno(EVMSERR);
8537     }
8538     set_vaxc_errno(retsts);
8539     if (ckWARN(WARN_EXEC)) {
8540       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8541              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8542     }
8543     vms_execfree(vmscmd);
8544   }
8545
8546   return FALSE;
8547
8548 }  /* end of vms_do_exec() */
8549 /*}}}*/
8550
8551 unsigned long int Perl_do_spawn(pTHX_ const char *);
8552
8553 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8554 unsigned long int
8555 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8556 {
8557 unsigned long int sts;
8558 char * cmd;
8559
8560   if (sp > mark) {
8561     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
8562     sts = do_spawn(cmd);
8563     /* pp_sys will clean up cmd */
8564     return sts;
8565   }
8566   return SS$_ABORT;
8567 }  /* end of do_aspawn() */
8568 /*}}}*/
8569
8570 /* {{{unsigned long int do_spawn(char *cmd) */
8571 unsigned long int
8572 Perl_do_spawn(pTHX_ const char *cmd)
8573 {
8574   unsigned long int sts, substs;
8575
8576   /* The caller of this routine expects to Safefree(PL_Cmd) */
8577   Newx(PL_Cmd,10,char);
8578
8579   TAINT_ENV();
8580   TAINT_PROPER("spawn");
8581   if (!cmd || !*cmd) {
8582     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8583     if (!(sts & 1)) {
8584       switch (sts) {
8585         case RMS$_FNF:  case RMS$_DNF:
8586           set_errno(ENOENT); break;
8587         case RMS$_DIR:
8588           set_errno(ENOTDIR); break;
8589         case RMS$_DEV:
8590           set_errno(ENODEV); break;
8591         case RMS$_PRV:
8592           set_errno(EACCES); break;
8593         case RMS$_SYN:
8594           set_errno(EINVAL); break;
8595         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8596           set_errno(E2BIG); break;
8597         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8598           _ckvmssts(sts); /* fall through */
8599         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8600           set_errno(EVMSERR);
8601       }
8602       set_vaxc_errno(sts);
8603       if (ckWARN(WARN_EXEC)) {
8604         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8605                     Strerror(errno));
8606       }
8607     }
8608     sts = substs;
8609   }
8610   else {
8611     PerlIO * fp;
8612     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8613     if (fp != NULL)
8614       my_pclose(fp);
8615   }
8616   return sts;
8617 }  /* end of do_spawn() */
8618 /*}}}*/
8619
8620
8621 static unsigned int *sockflags, sockflagsize;
8622
8623 /*
8624  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8625  * routines found in some versions of the CRTL can't deal with sockets.
8626  * We don't shim the other file open routines since a socket isn't
8627  * likely to be opened by a name.
8628  */
8629 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8630 FILE *my_fdopen(int fd, const char *mode)
8631 {
8632   FILE *fp = fdopen(fd, mode);
8633
8634   if (fp) {
8635     unsigned int fdoff = fd / sizeof(unsigned int);
8636     Stat_t sbuf; /* native stat; we don't need flex_stat */
8637     if (!sockflagsize || fdoff > sockflagsize) {
8638       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
8639       else           Newx  (sockflags,fdoff+2,unsigned int);
8640       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8641       sockflagsize = fdoff + 2;
8642     }
8643     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8644       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8645   }
8646   return fp;
8647
8648 }
8649 /*}}}*/
8650
8651
8652 /*
8653  * Clear the corresponding bit when the (possibly) socket stream is closed.
8654  * There still a small hole: we miss an implicit close which might occur
8655  * via freopen().  >> Todo
8656  */
8657 /*{{{ int my_fclose(FILE *fp)*/
8658 int my_fclose(FILE *fp) {
8659   if (fp) {
8660     unsigned int fd = fileno(fp);
8661     unsigned int fdoff = fd / sizeof(unsigned int);
8662
8663     if (sockflagsize && fdoff <= sockflagsize)
8664       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8665   }
8666   return fclose(fp);
8667 }
8668 /*}}}*/
8669
8670
8671 /*
8672  * A simple fwrite replacement which outputs itmsz*nitm chars without
8673  * introducing record boundaries every itmsz chars.
8674  * We are using fputs, which depends on a terminating null.  We may
8675  * well be writing binary data, so we need to accommodate not only
8676  * data with nulls sprinkled in the middle but also data with no null
8677  * byte at the end.
8678  */
8679 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8680 int
8681 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8682 {
8683   register char *cp, *end, *cpd, *data;
8684   register unsigned int fd = fileno(dest);
8685   register unsigned int fdoff = fd / sizeof(unsigned int);
8686   int retval;
8687   int bufsize = itmsz * nitm + 1;
8688
8689   if (fdoff < sockflagsize &&
8690       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8691     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8692     return nitm;
8693   }
8694
8695   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8696   memcpy( data, src, itmsz*nitm );
8697   data[itmsz*nitm] = '\0';
8698
8699   end = data + itmsz * nitm;
8700   retval = (int) nitm; /* on success return # items written */
8701
8702   cpd = data;
8703   while (cpd <= end) {
8704     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8705     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8706     if (cp < end)
8707       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8708     cpd = cp + 1;
8709   }
8710
8711   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8712   return retval;
8713
8714 }  /* end of my_fwrite() */
8715 /*}}}*/
8716
8717 /*{{{ int my_flush(FILE *fp)*/
8718 int
8719 Perl_my_flush(pTHX_ FILE *fp)
8720 {
8721     int res;
8722     if ((res = fflush(fp)) == 0 && fp) {
8723 #ifdef VMS_DO_SOCKETS
8724         Stat_t s;
8725         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8726 #endif
8727             res = fsync(fileno(fp));
8728     }
8729 /*
8730  * If the flush succeeded but set end-of-file, we need to clear
8731  * the error because our caller may check ferror().  BTW, this
8732  * probably means we just flushed an empty file.
8733  */
8734     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8735
8736     return res;
8737 }
8738 /*}}}*/
8739
8740 /*
8741  * Here are replacements for the following Unix routines in the VMS environment:
8742  *      getpwuid    Get information for a particular UIC or UID
8743  *      getpwnam    Get information for a named user
8744  *      getpwent    Get information for each user in the rights database
8745  *      setpwent    Reset search to the start of the rights database
8746  *      endpwent    Finish searching for users in the rights database
8747  *
8748  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8749  * (defined in pwd.h), which contains the following fields:-
8750  *      struct passwd {
8751  *              char        *pw_name;    Username (in lower case)
8752  *              char        *pw_passwd;  Hashed password
8753  *              unsigned int pw_uid;     UIC
8754  *              unsigned int pw_gid;     UIC group  number
8755  *              char        *pw_unixdir; Default device/directory (VMS-style)
8756  *              char        *pw_gecos;   Owner name
8757  *              char        *pw_dir;     Default device/directory (Unix-style)
8758  *              char        *pw_shell;   Default CLI name (eg. DCL)
8759  *      };
8760  * If the specified user does not exist, getpwuid and getpwnam return NULL.
8761  *
8762  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8763  * not the UIC member number (eg. what's returned by getuid()),
8764  * getpwuid() can accept either as input (if uid is specified, the caller's
8765  * UIC group is used), though it won't recognise gid=0.
8766  *
8767  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8768  * information about other users in your group or in other groups, respectively.
8769  * If the required privilege is not available, then these routines fill only
8770  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8771  * string).
8772  *
8773  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8774  */
8775
8776 /* sizes of various UAF record fields */
8777 #define UAI$S_USERNAME 12
8778 #define UAI$S_IDENT    31
8779 #define UAI$S_OWNER    31
8780 #define UAI$S_DEFDEV   31
8781 #define UAI$S_DEFDIR   63
8782 #define UAI$S_DEFCLI   31
8783 #define UAI$S_PWD       8
8784
8785 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
8786                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8787                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
8788
8789 static char __empty[]= "";
8790 static struct passwd __passwd_empty=
8791     {(char *) __empty, (char *) __empty, 0, 0,
8792      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8793 static int contxt= 0;
8794 static struct passwd __pwdcache;
8795 static char __pw_namecache[UAI$S_IDENT+1];
8796
8797 /*
8798  * This routine does most of the work extracting the user information.
8799  */
8800 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8801 {
8802     static struct {
8803         unsigned char length;
8804         char pw_gecos[UAI$S_OWNER+1];
8805     } owner;
8806     static union uicdef uic;
8807     static struct {
8808         unsigned char length;
8809         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8810     } defdev;
8811     static struct {
8812         unsigned char length;
8813         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8814     } defdir;
8815     static struct {
8816         unsigned char length;
8817         char pw_shell[UAI$S_DEFCLI+1];
8818     } defcli;
8819     static char pw_passwd[UAI$S_PWD+1];
8820
8821     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8822     struct dsc$descriptor_s name_desc;
8823     unsigned long int sts;
8824
8825     static struct itmlst_3 itmlst[]= {
8826         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
8827         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
8828         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
8829         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
8830         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
8831         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
8832         {0,                0,           NULL,    NULL}};
8833
8834     name_desc.dsc$w_length=  strlen(name);
8835     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8836     name_desc.dsc$b_class=   DSC$K_CLASS_S;
8837     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8838
8839 /*  Note that sys$getuai returns many fields as counted strings. */
8840     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8841     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8842       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8843     }
8844     else { _ckvmssts(sts); }
8845     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
8846
8847     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
8848     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8849     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8850     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8851     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8852     owner.pw_gecos[lowner]=            '\0';
8853     defdev.pw_dir[ldefdev+ldefdir]= '\0';
8854     defcli.pw_shell[ldefcli]=          '\0';
8855     if (valid_uic(uic)) {
8856         pwd->pw_uid= uic.uic$l_uic;
8857         pwd->pw_gid= uic.uic$v_group;
8858     }
8859     else
8860       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8861     pwd->pw_passwd=  pw_passwd;
8862     pwd->pw_gecos=   owner.pw_gecos;
8863     pwd->pw_dir=     defdev.pw_dir;
8864     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8865     pwd->pw_shell=   defcli.pw_shell;
8866     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8867         int ldir;
8868         ldir= strlen(pwd->pw_unixdir) - 1;
8869         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8870     }
8871     else
8872         strcpy(pwd->pw_unixdir, pwd->pw_dir);
8873     if (!decc_efs_case_preserve)
8874         __mystrtolower(pwd->pw_unixdir);
8875     return 1;
8876 }
8877
8878 /*
8879  * Get information for a named user.
8880 */
8881 /*{{{struct passwd *getpwnam(char *name)*/
8882 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8883 {
8884     struct dsc$descriptor_s name_desc;
8885     union uicdef uic;
8886     unsigned long int status, sts;
8887
8888     __pwdcache = __passwd_empty;
8889     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8890       /* We still may be able to determine pw_uid and pw_gid */
8891       name_desc.dsc$w_length=  strlen(name);
8892       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8893       name_desc.dsc$b_class=   DSC$K_CLASS_S;
8894       name_desc.dsc$a_pointer= (char *) name;
8895       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
8896         __pwdcache.pw_uid= uic.uic$l_uic;
8897         __pwdcache.pw_gid= uic.uic$v_group;
8898       }
8899       else {
8900         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8901           set_vaxc_errno(sts);
8902           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
8903           return NULL;
8904         }
8905         else { _ckvmssts(sts); }
8906       }
8907     }
8908     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8909     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8910     __pwdcache.pw_name= __pw_namecache;
8911     return &__pwdcache;
8912 }  /* end of my_getpwnam() */
8913 /*}}}*/
8914
8915 /*
8916  * Get information for a particular UIC or UID.
8917  * Called by my_getpwent with uid=-1 to list all users.
8918 */
8919 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
8920 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
8921 {
8922     const $DESCRIPTOR(name_desc,__pw_namecache);
8923     unsigned short lname;
8924     union uicdef uic;
8925     unsigned long int status;
8926
8927     if (uid == (unsigned int) -1) {
8928       do {
8929         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
8930         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
8931           set_vaxc_errno(status);
8932           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8933           my_endpwent();
8934           return NULL;
8935         }
8936         else { _ckvmssts(status); }
8937       } while (!valid_uic (uic));
8938     }
8939     else {
8940       uic.uic$l_uic= uid;
8941       if (!uic.uic$v_group)
8942         uic.uic$v_group= PerlProc_getgid();
8943       if (valid_uic(uic))
8944         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
8945       else status = SS$_IVIDENT;
8946       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
8947           status == RMS$_PRV) {
8948         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8949         return NULL;
8950       }
8951       else { _ckvmssts(status); }
8952     }
8953     __pw_namecache[lname]= '\0';
8954     __mystrtolower(__pw_namecache);
8955
8956     __pwdcache = __passwd_empty;
8957     __pwdcache.pw_name = __pw_namecache;
8958
8959 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
8960     The identifier's value is usually the UIC, but it doesn't have to be,
8961     so if we can, we let fillpasswd update this. */
8962     __pwdcache.pw_uid =  uic.uic$l_uic;
8963     __pwdcache.pw_gid =  uic.uic$v_group;
8964
8965     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
8966     return &__pwdcache;
8967
8968 }  /* end of my_getpwuid() */
8969 /*}}}*/
8970
8971 /*
8972  * Get information for next user.
8973 */
8974 /*{{{struct passwd *my_getpwent()*/
8975 struct passwd *Perl_my_getpwent(pTHX)
8976 {
8977     return (my_getpwuid((unsigned int) -1));
8978 }
8979 /*}}}*/
8980
8981 /*
8982  * Finish searching rights database for users.
8983 */
8984 /*{{{void my_endpwent()*/
8985 void Perl_my_endpwent(pTHX)
8986 {
8987     if (contxt) {
8988       _ckvmssts(sys$finish_rdb(&contxt));
8989       contxt= 0;
8990     }
8991 }
8992 /*}}}*/
8993
8994 #ifdef HOMEGROWN_POSIX_SIGNALS
8995   /* Signal handling routines, pulled into the core from POSIX.xs.
8996    *
8997    * We need these for threads, so they've been rolled into the core,
8998    * rather than left in POSIX.xs.
8999    *
9000    * (DRS, Oct 23, 1997)
9001    */
9002
9003   /* sigset_t is atomic under VMS, so these routines are easy */
9004 /*{{{int my_sigemptyset(sigset_t *) */
9005 int my_sigemptyset(sigset_t *set) {
9006     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9007     *set = 0; return 0;
9008 }
9009 /*}}}*/
9010
9011
9012 /*{{{int my_sigfillset(sigset_t *)*/
9013 int my_sigfillset(sigset_t *set) {
9014     int i;
9015     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9016     for (i = 0; i < NSIG; i++) *set |= (1 << i);
9017     return 0;
9018 }
9019 /*}}}*/
9020
9021
9022 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9023 int my_sigaddset(sigset_t *set, int sig) {
9024     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9025     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9026     *set |= (1 << (sig - 1));
9027     return 0;
9028 }
9029 /*}}}*/
9030
9031
9032 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9033 int my_sigdelset(sigset_t *set, int sig) {
9034     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9035     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9036     *set &= ~(1 << (sig - 1));
9037     return 0;
9038 }
9039 /*}}}*/
9040
9041
9042 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9043 int my_sigismember(sigset_t *set, int sig) {
9044     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9045     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9046     return *set & (1 << (sig - 1));
9047 }
9048 /*}}}*/
9049
9050
9051 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9052 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9053     sigset_t tempmask;
9054
9055     /* If set and oset are both null, then things are badly wrong. Bail out. */
9056     if ((oset == NULL) && (set == NULL)) {
9057       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9058       return -1;
9059     }
9060
9061     /* If set's null, then we're just handling a fetch. */
9062     if (set == NULL) {
9063         tempmask = sigblock(0);
9064     }
9065     else {
9066       switch (how) {
9067       case SIG_SETMASK:
9068         tempmask = sigsetmask(*set);
9069         break;
9070       case SIG_BLOCK:
9071         tempmask = sigblock(*set);
9072         break;
9073       case SIG_UNBLOCK:
9074         tempmask = sigblock(0);
9075         sigsetmask(*oset & ~tempmask);
9076         break;
9077       default:
9078         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9079         return -1;
9080       }
9081     }
9082
9083     /* Did they pass us an oset? If so, stick our holding mask into it */
9084     if (oset)
9085       *oset = tempmask;
9086
9087     return 0;
9088 }
9089 /*}}}*/
9090 #endif  /* HOMEGROWN_POSIX_SIGNALS */
9091
9092
9093 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9094  * my_utime(), and flex_stat(), all of which operate on UTC unless
9095  * VMSISH_TIMES is true.
9096  */
9097 /* method used to handle UTC conversions:
9098  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
9099  */
9100 static int gmtime_emulation_type;
9101 /* number of secs to add to UTC POSIX-style time to get local time */
9102 static long int utc_offset_secs;
9103
9104 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9105  * in vmsish.h.  #undef them here so we can call the CRTL routines
9106  * directly.
9107  */
9108 #undef gmtime
9109 #undef localtime
9110 #undef time
9111
9112
9113 /*
9114  * DEC C previous to 6.0 corrupts the behavior of the /prefix
9115  * qualifier with the extern prefix pragma.  This provisional
9116  * hack circumvents this prefix pragma problem in previous
9117  * precompilers.
9118  */
9119 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9120 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9121 #    pragma __extern_prefix save
9122 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
9123 #    define gmtime decc$__utctz_gmtime
9124 #    define localtime decc$__utctz_localtime
9125 #    define time decc$__utc_time
9126 #    pragma __extern_prefix restore
9127
9128      struct tm *gmtime(), *localtime();
9129
9130 #  endif
9131 #endif
9132
9133
9134 static time_t toutc_dst(time_t loc) {
9135   struct tm *rsltmp;
9136
9137   if ((rsltmp = localtime(&loc)) == NULL) return -1;
9138   loc -= utc_offset_secs;
9139   if (rsltmp->tm_isdst) loc -= 3600;
9140   return loc;
9141 }
9142 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9143        ((gmtime_emulation_type || my_time(NULL)), \
9144        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9145        ((secs) - utc_offset_secs))))
9146
9147 static time_t toloc_dst(time_t utc) {
9148   struct tm *rsltmp;
9149
9150   utc += utc_offset_secs;
9151   if ((rsltmp = localtime(&utc)) == NULL) return -1;
9152   if (rsltmp->tm_isdst) utc += 3600;
9153   return utc;
9154 }
9155 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9156        ((gmtime_emulation_type || my_time(NULL)), \
9157        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9158        ((secs) + utc_offset_secs))))
9159
9160 #ifndef RTL_USES_UTC
9161 /*
9162
9163     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
9164         DST starts on 1st sun of april      at 02:00  std time
9165             ends on last sun of october     at 02:00  dst time
9166     see the UCX management command reference, SET CONFIG TIMEZONE
9167     for formatting info.
9168
9169     No, it's not as general as it should be, but then again, NOTHING
9170     will handle UK times in a sensible way.
9171 */
9172
9173
9174 /*
9175     parse the DST start/end info:
9176     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9177 */
9178
9179 static char *
9180 tz_parse_startend(char *s, struct tm *w, int *past)
9181 {
9182     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9183     int ly, dozjd, d, m, n, hour, min, sec, j, k;
9184     time_t g;
9185
9186     if (!s)    return 0;
9187     if (!w) return 0;
9188     if (!past) return 0;
9189
9190     ly = 0;
9191     if (w->tm_year % 4        == 0) ly = 1;
9192     if (w->tm_year % 100      == 0) ly = 0;
9193     if (w->tm_year+1900 % 400 == 0) ly = 1;
9194     if (ly) dinm[1]++;
9195
9196     dozjd = isdigit(*s);
9197     if (*s == 'J' || *s == 'j' || dozjd) {
9198         if (!dozjd && !isdigit(*++s)) return 0;
9199         d = *s++ - '0';
9200         if (isdigit(*s)) {
9201             d = d*10 + *s++ - '0';
9202             if (isdigit(*s)) {
9203                 d = d*10 + *s++ - '0';
9204             }
9205         }
9206         if (d == 0) return 0;
9207         if (d > 366) return 0;
9208         d--;
9209         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
9210         g = d * 86400;
9211         dozjd = 1;
9212     } else if (*s == 'M' || *s == 'm') {
9213         if (!isdigit(*++s)) return 0;
9214         m = *s++ - '0';
9215         if (isdigit(*s)) m = 10*m + *s++ - '0';
9216         if (*s != '.') return 0;
9217         if (!isdigit(*++s)) return 0;
9218         n = *s++ - '0';
9219         if (n < 1 || n > 5) return 0;
9220         if (*s != '.') return 0;
9221         if (!isdigit(*++s)) return 0;
9222         d = *s++ - '0';
9223         if (d > 6) return 0;
9224     }
9225
9226     if (*s == '/') {
9227         if (!isdigit(*++s)) return 0;
9228         hour = *s++ - '0';
9229         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9230         if (*s == ':') {
9231             if (!isdigit(*++s)) return 0;
9232             min = *s++ - '0';
9233             if (isdigit(*s)) min = 10*min + *s++ - '0';
9234             if (*s == ':') {
9235                 if (!isdigit(*++s)) return 0;
9236                 sec = *s++ - '0';
9237                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9238             }
9239         }
9240     } else {
9241         hour = 2;
9242         min = 0;
9243         sec = 0;
9244     }
9245
9246     if (dozjd) {
9247         if (w->tm_yday < d) goto before;
9248         if (w->tm_yday > d) goto after;
9249     } else {
9250         if (w->tm_mon+1 < m) goto before;
9251         if (w->tm_mon+1 > m) goto after;
9252
9253         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
9254         k = d - j; /* mday of first d */
9255         if (k <= 0) k += 7;
9256         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
9257         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9258         if (w->tm_mday < k) goto before;
9259         if (w->tm_mday > k) goto after;
9260     }
9261
9262     if (w->tm_hour < hour) goto before;
9263     if (w->tm_hour > hour) goto after;
9264     if (w->tm_min  < min)  goto before;
9265     if (w->tm_min  > min)  goto after;
9266     if (w->tm_sec  < sec)  goto before;
9267     goto after;
9268
9269 before:
9270     *past = 0;
9271     return s;
9272 after:
9273     *past = 1;
9274     return s;
9275 }
9276
9277
9278
9279
9280 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
9281
9282 static char *
9283 tz_parse_offset(char *s, int *offset)
9284 {
9285     int hour = 0, min = 0, sec = 0;
9286     int neg = 0;
9287     if (!s) return 0;
9288     if (!offset) return 0;
9289
9290     if (*s == '-') {neg++; s++;}
9291     if (*s == '+') s++;
9292     if (!isdigit(*s)) return 0;
9293     hour = *s++ - '0';
9294     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
9295     if (hour > 24) return 0;
9296     if (*s == ':') {
9297         if (!isdigit(*++s)) return 0;
9298         min = *s++ - '0';
9299         if (isdigit(*s)) min = min*10 + (*s++ - '0');
9300         if (min > 59) return 0;
9301         if (*s == ':') {
9302             if (!isdigit(*++s)) return 0;
9303             sec = *s++ - '0';
9304             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
9305             if (sec > 59) return 0;
9306         }
9307     }
9308
9309     *offset = (hour*60+min)*60 + sec;
9310     if (neg) *offset = -*offset;
9311     return s;
9312 }
9313
9314 /*
9315     input time is w, whatever type of time the CRTL localtime() uses.
9316     sets dst, the zone, and the gmtoff (seconds)
9317
9318     caches the value of TZ and UCX$TZ env variables; note that
9319     my_setenv looks for these and sets a flag if they're changed
9320     for efficiency.
9321
9322     We have to watch out for the "australian" case (dst starts in
9323     october, ends in april)...flagged by "reverse" and checked by
9324     scanning through the months of the previous year.
9325
9326 */
9327
9328 static int
9329 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
9330 {
9331     time_t when;
9332     struct tm *w2;
9333     char *s,*s2;
9334     char *dstzone, *tz, *s_start, *s_end;
9335     int std_off, dst_off, isdst;
9336     int y, dststart, dstend;
9337     static char envtz[1025];  /* longer than any logical, symbol, ... */
9338     static char ucxtz[1025];
9339     static char reversed = 0;
9340
9341     if (!w) return 0;
9342
9343     if (tz_updated) {
9344         tz_updated = 0;
9345         reversed = -1;  /* flag need to check  */
9346         envtz[0] = ucxtz[0] = '\0';
9347         tz = my_getenv("TZ",0);
9348         if (tz) strcpy(envtz, tz);
9349         tz = my_getenv("UCX$TZ",0);
9350         if (tz) strcpy(ucxtz, tz);
9351         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
9352     }
9353     tz = envtz;
9354     if (!*tz) tz = ucxtz;
9355
9356     s = tz;
9357     while (isalpha(*s)) s++;
9358     s = tz_parse_offset(s, &std_off);
9359     if (!s) return 0;
9360     if (!*s) {                  /* no DST, hurray we're done! */
9361         isdst = 0;
9362         goto done;
9363     }
9364
9365     dstzone = s;
9366     while (isalpha(*s)) s++;
9367     s2 = tz_parse_offset(s, &dst_off);
9368     if (s2) {
9369         s = s2;
9370     } else {
9371         dst_off = std_off - 3600;
9372     }
9373
9374     if (!*s) {      /* default dst start/end?? */
9375         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
9376             s = strchr(ucxtz,',');
9377         }
9378         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
9379     }
9380     if (*s != ',') return 0;
9381
9382     when = *w;
9383     when = _toutc(when);      /* convert to utc */
9384     when = when - std_off;    /* convert to pseudolocal time*/
9385
9386     w2 = localtime(&when);
9387     y = w2->tm_year;
9388     s_start = s+1;
9389     s = tz_parse_startend(s_start,w2,&dststart);
9390     if (!s) return 0;
9391     if (*s != ',') return 0;
9392
9393     when = *w;
9394     when = _toutc(when);      /* convert to utc */
9395     when = when - dst_off;    /* convert to pseudolocal time*/
9396     w2 = localtime(&when);
9397     if (w2->tm_year != y) {   /* spans a year, just check one time */
9398         when += dst_off - std_off;
9399         w2 = localtime(&when);
9400     }
9401     s_end = s+1;
9402     s = tz_parse_startend(s_end,w2,&dstend);
9403     if (!s) return 0;
9404
9405     if (reversed == -1) {  /* need to check if start later than end */
9406         int j, ds, de;
9407
9408         when = *w;
9409         if (when < 2*365*86400) {
9410             when += 2*365*86400;
9411         } else {
9412             when -= 365*86400;
9413         }
9414         w2 =localtime(&when);
9415         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
9416
9417         for (j = 0; j < 12; j++) {
9418             w2 =localtime(&when);
9419             tz_parse_startend(s_start,w2,&ds);
9420             tz_parse_startend(s_end,w2,&de);
9421             if (ds != de) break;
9422             when += 30*86400;
9423         }
9424         reversed = 0;
9425         if (de && !ds) reversed = 1;
9426     }
9427
9428     isdst = dststart && !dstend;
9429     if (reversed) isdst = dststart  || !dstend;
9430
9431 done:
9432     if (dst)    *dst = isdst;
9433     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9434     if (isdst)  tz = dstzone;
9435     if (zone) {
9436         while(isalpha(*tz))  *zone++ = *tz++;
9437         *zone = '\0';
9438     }
9439     return 1;
9440 }
9441
9442 #endif /* !RTL_USES_UTC */
9443
9444 /* my_time(), my_localtime(), my_gmtime()
9445  * By default traffic in UTC time values, using CRTL gmtime() or
9446  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9447  * Note: We need to use these functions even when the CRTL has working
9448  * UTC support, since they also handle C<use vmsish qw(times);>
9449  *
9450  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
9451  * Modified by Charles Bailey <bailey@newman.upenn.edu>
9452  */
9453
9454 /*{{{time_t my_time(time_t *timep)*/
9455 time_t Perl_my_time(pTHX_ time_t *timep)
9456 {
9457   time_t when;
9458   struct tm *tm_p;
9459
9460   if (gmtime_emulation_type == 0) {
9461     int dstnow;
9462     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
9463                               /* results of calls to gmtime() and localtime() */
9464                               /* for same &base */
9465
9466     gmtime_emulation_type++;
9467     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9468       char off[LNM$C_NAMLENGTH+1];;
9469
9470       gmtime_emulation_type++;
9471       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9472         gmtime_emulation_type++;
9473         utc_offset_secs = 0;
9474         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9475       }
9476       else { utc_offset_secs = atol(off); }
9477     }
9478     else { /* We've got a working gmtime() */
9479       struct tm gmt, local;
9480
9481       gmt = *tm_p;
9482       tm_p = localtime(&base);
9483       local = *tm_p;
9484       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
9485       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9486       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
9487       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
9488     }
9489   }
9490
9491   when = time(NULL);
9492 # ifdef VMSISH_TIME
9493 # ifdef RTL_USES_UTC
9494   if (VMSISH_TIME) when = _toloc(when);
9495 # else
9496   if (!VMSISH_TIME) when = _toutc(when);
9497 # endif
9498 # endif
9499   if (timep != NULL) *timep = when;
9500   return when;
9501
9502 }  /* end of my_time() */
9503 /*}}}*/
9504
9505
9506 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9507 struct tm *
9508 Perl_my_gmtime(pTHX_ const time_t *timep)
9509 {
9510   char *p;
9511   time_t when;
9512   struct tm *rsltmp;
9513
9514   if (timep == NULL) {
9515     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9516     return NULL;
9517   }
9518   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9519
9520   when = *timep;
9521 # ifdef VMSISH_TIME
9522   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9523 #  endif
9524 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
9525   return gmtime(&when);
9526 # else
9527   /* CRTL localtime() wants local time as input, so does no tz correction */
9528   rsltmp = localtime(&when);
9529   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
9530   return rsltmp;
9531 #endif
9532 }  /* end of my_gmtime() */
9533 /*}}}*/
9534
9535
9536 /*{{{struct tm *my_localtime(const time_t *timep)*/
9537 struct tm *
9538 Perl_my_localtime(pTHX_ const time_t *timep)
9539 {
9540   time_t when, whenutc;
9541   struct tm *rsltmp;
9542   int dst, offset;
9543
9544   if (timep == NULL) {
9545     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9546     return NULL;
9547   }
9548   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9549   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9550
9551   when = *timep;
9552 # ifdef RTL_USES_UTC
9553 # ifdef VMSISH_TIME
9554   if (VMSISH_TIME) when = _toutc(when);
9555 # endif
9556   /* CRTL localtime() wants UTC as input, does tz correction itself */
9557   return localtime(&when);
9558
9559 # else /* !RTL_USES_UTC */
9560   whenutc = when;
9561 # ifdef VMSISH_TIME
9562   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
9563   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
9564 # endif
9565   dst = -1;
9566 #ifndef RTL_USES_UTC
9567   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
9568       when = whenutc - offset;                   /* pseudolocal time*/
9569   }
9570 # endif
9571   /* CRTL localtime() wants local time as input, so does no tz correction */
9572   rsltmp = localtime(&when);
9573   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9574   return rsltmp;
9575 # endif
9576
9577 } /*  end of my_localtime() */
9578 /*}}}*/
9579
9580 /* Reset definitions for later calls */
9581 #define gmtime(t)    my_gmtime(t)
9582 #define localtime(t) my_localtime(t)
9583 #define time(t)      my_time(t)
9584
9585
9586 /* my_utime - update modification/access time of a file
9587  *
9588  * VMS 7.3 and later implementation
9589  * Only the UTC translation is home-grown. The rest is handled by the
9590  * CRTL utime(), which will take into account the relevant feature
9591  * logicals and ODS-5 volume characteristics for true access times.
9592  *
9593  * pre VMS 7.3 implementation:
9594  * The calling sequence is identical to POSIX utime(), but under
9595  * VMS with ODS-2, only the modification time is changed; ODS-2 does
9596  * not maintain access times.  Restrictions differ from the POSIX
9597  * definition in that the time can be changed as long as the
9598  * caller has permission to execute the necessary IO$_MODIFY $QIO;
9599  * no separate checks are made to insure that the caller is the
9600  * owner of the file or has special privs enabled.
9601  * Code here is based on Joe Meadows' FILE utility.
9602  *
9603  */
9604
9605 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9606  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
9607  * in 100 ns intervals.
9608  */
9609 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9610
9611 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9612 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9613 {
9614 #if __CRTL_VER >= 70300000
9615   struct utimbuf utc_utimes, *utc_utimesp;
9616
9617   if (utimes != NULL) {
9618     utc_utimes.actime = utimes->actime;
9619     utc_utimes.modtime = utimes->modtime;
9620 # ifdef VMSISH_TIME
9621     /* If input was local; convert to UTC for sys svc */
9622     if (VMSISH_TIME) {
9623       utc_utimes.actime = _toutc(utimes->actime);
9624       utc_utimes.modtime = _toutc(utimes->modtime);
9625     }
9626 # endif
9627     utc_utimesp = &utc_utimes;
9628   }
9629   else {
9630     utc_utimesp = NULL;
9631   }
9632
9633   return utime(file, utc_utimesp);
9634
9635 #else /* __CRTL_VER < 70300000 */
9636
9637   register int i;
9638   int sts;
9639   long int bintime[2], len = 2, lowbit, unixtime,
9640            secscale = 10000000; /* seconds --> 100 ns intervals */
9641   unsigned long int chan, iosb[2], retsts;
9642   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9643   struct FAB myfab = cc$rms_fab;
9644   struct NAM mynam = cc$rms_nam;
9645 #if defined (__DECC) && defined (__VAX)
9646   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9647    * at least through VMS V6.1, which causes a type-conversion warning.
9648    */
9649 #  pragma message save
9650 #  pragma message disable cvtdiftypes
9651 #endif
9652   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9653   struct fibdef myfib;
9654 #if defined (__DECC) && defined (__VAX)
9655   /* This should be right after the declaration of myatr, but due
9656    * to a bug in VAX DEC C, this takes effect a statement early.
9657    */
9658 #  pragma message restore
9659 #endif
9660   /* cast ok for read only parameter */
9661   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9662                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9663                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9664
9665   if (file == NULL || *file == '\0') {
9666     SETERRNO(ENOENT, LIB$_INVARG);
9667     return -1;
9668   }
9669
9670   /* Convert to VMS format ensuring that it will fit in 255 characters */
9671   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
9672       SETERRNO(ENOENT, LIB$_INVARG);
9673       return -1;
9674   }
9675   if (utimes != NULL) {
9676     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
9677      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9678      * Since time_t is unsigned long int, and lib$emul takes a signed long int
9679      * as input, we force the sign bit to be clear by shifting unixtime right
9680      * one bit, then multiplying by an extra factor of 2 in lib$emul().
9681      */
9682     lowbit = (utimes->modtime & 1) ? secscale : 0;
9683     unixtime = (long int) utimes->modtime;
9684 #   ifdef VMSISH_TIME
9685     /* If input was UTC; convert to local for sys svc */
9686     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9687 #   endif
9688     unixtime >>= 1;  secscale <<= 1;
9689     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9690     if (!(retsts & 1)) {
9691       SETERRNO(EVMSERR, retsts);
9692       return -1;
9693     }
9694     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9695     if (!(retsts & 1)) {
9696       SETERRNO(EVMSERR, retsts);
9697       return -1;
9698     }
9699   }
9700   else {
9701     /* Just get the current time in VMS format directly */
9702     retsts = sys$gettim(bintime);
9703     if (!(retsts & 1)) {
9704       SETERRNO(EVMSERR, retsts);
9705       return -1;
9706     }
9707   }
9708
9709   myfab.fab$l_fna = vmsspec;
9710   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9711   myfab.fab$l_nam = &mynam;
9712   mynam.nam$l_esa = esa;
9713   mynam.nam$b_ess = (unsigned char) sizeof esa;
9714   mynam.nam$l_rsa = rsa;
9715   mynam.nam$b_rss = (unsigned char) sizeof rsa;
9716   if (decc_efs_case_preserve)
9717       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9718
9719   /* Look for the file to be affected, letting RMS parse the file
9720    * specification for us as well.  I have set errno using only
9721    * values documented in the utime() man page for VMS POSIX.
9722    */
9723   retsts = sys$parse(&myfab,0,0);
9724   if (!(retsts & 1)) {
9725     set_vaxc_errno(retsts);
9726     if      (retsts == RMS$_PRV) set_errno(EACCES);
9727     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9728     else                         set_errno(EVMSERR);
9729     return -1;
9730   }
9731   retsts = sys$search(&myfab,0,0);
9732   if (!(retsts & 1)) {
9733     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9734     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9735     set_vaxc_errno(retsts);
9736     if      (retsts == RMS$_PRV) set_errno(EACCES);
9737     else if (retsts == RMS$_FNF) set_errno(ENOENT);
9738     else                         set_errno(EVMSERR);
9739     return -1;
9740   }
9741
9742   devdsc.dsc$w_length = mynam.nam$b_dev;
9743   /* cast ok for read only parameter */
9744   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9745
9746   retsts = sys$assign(&devdsc,&chan,0,0);
9747   if (!(retsts & 1)) {
9748     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9749     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9750     set_vaxc_errno(retsts);
9751     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
9752     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
9753     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
9754     else                               set_errno(EVMSERR);
9755     return -1;
9756   }
9757
9758   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9759   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9760
9761   memset((void *) &myfib, 0, sizeof myfib);
9762 #if defined(__DECC) || defined(__DECCXX)
9763   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9764   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9765   /* This prevents the revision time of the file being reset to the current
9766    * time as a result of our IO$_MODIFY $QIO. */
9767   myfib.fib$l_acctl = FIB$M_NORECORD;
9768 #else
9769   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9770   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9771   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9772 #endif
9773   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9774   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9775   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9776   _ckvmssts(sys$dassgn(chan));
9777   if (retsts & 1) retsts = iosb[0];
9778   if (!(retsts & 1)) {
9779     set_vaxc_errno(retsts);
9780     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9781     else                      set_errno(EVMSERR);
9782     return -1;
9783   }
9784
9785   return 0;
9786
9787 #endif /* #if __CRTL_VER >= 70300000 */
9788
9789 }  /* end of my_utime() */
9790 /*}}}*/
9791
9792 /*
9793  * flex_stat, flex_lstat, flex_fstat
9794  * basic stat, but gets it right when asked to stat
9795  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9796  */
9797
9798 #ifndef _USE_STD_STAT
9799 /* encode_dev packs a VMS device name string into an integer to allow
9800  * simple comparisons. This can be used, for example, to check whether two
9801  * files are located on the same device, by comparing their encoded device
9802  * names. Even a string comparison would not do, because stat() reuses the
9803  * device name buffer for each call; so without encode_dev, it would be
9804  * necessary to save the buffer and use strcmp (this would mean a number of
9805  * changes to the standard Perl code, to say nothing of what a Perl script
9806  * would have to do.
9807  *
9808  * The device lock id, if it exists, should be unique (unless perhaps compared
9809  * with lock ids transferred from other nodes). We have a lock id if the disk is
9810  * mounted cluster-wide, which is when we tend to get long (host-qualified)
9811  * device names. Thus we use the lock id in preference, and only if that isn't
9812  * available, do we try to pack the device name into an integer (flagged by
9813  * the sign bit (LOCKID_MASK) being set).
9814  *
9815  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9816  * name and its encoded form, but it seems very unlikely that we will find
9817  * two files on different disks that share the same encoded device names,
9818  * and even more remote that they will share the same file id (if the test
9819  * is to check for the same file).
9820  *
9821  * A better method might be to use sys$device_scan on the first call, and to
9822  * search for the device, returning an index into the cached array.
9823  * The number returned would be more intelligable.
9824  * This is probably not worth it, and anyway would take quite a bit longer
9825  * on the first call.
9826  */
9827 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
9828 static mydev_t encode_dev (pTHX_ const char *dev)
9829 {
9830   int i;
9831   unsigned long int f;
9832   mydev_t enc;
9833   char c;
9834   const char *q;
9835
9836   if (!dev || !dev[0]) return 0;
9837
9838 #if LOCKID_MASK
9839   {
9840     struct dsc$descriptor_s dev_desc;
9841     unsigned long int status, lockid, item = DVI$_LOCKID;
9842
9843     /* For cluster-mounted disks, the disk lock identifier is unique, so we
9844        can try that first. */
9845     dev_desc.dsc$w_length =  strlen (dev);
9846     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
9847     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
9848     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
9849     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9850     if (lockid) return (lockid & ~LOCKID_MASK);
9851   }
9852 #endif
9853
9854   /* Otherwise we try to encode the device name */
9855   enc = 0;
9856   f = 1;
9857   i = 0;
9858   for (q = dev + strlen(dev); q--; q >= dev) {
9859     if (*q == ':')
9860         break;
9861     if (isdigit (*q))
9862       c= (*q) - '0';
9863     else if (isalpha (toupper (*q)))
9864       c= toupper (*q) - 'A' + (char)10;
9865     else
9866       continue; /* Skip '$'s */
9867     i++;
9868     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
9869     if (i>1) f *= 36;
9870     enc += f * (unsigned long int) c;
9871   }
9872   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
9873
9874 }  /* end of encode_dev() */
9875 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
9876         device_no = encode_dev(aTHX_ devname)
9877 #else
9878 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
9879         device_no = new_dev_no
9880 #endif
9881
9882 static int
9883 is_null_device(name)
9884     const char *name;
9885 {
9886   if (decc_bug_devnull != 0) {
9887     if (strncmp("/dev/null", name, 9) == 0)
9888       return 1;
9889   }
9890     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9891        The underscore prefix, controller letter, and unit number are
9892        independently optional; for our purposes, the colon punctuation
9893        is not.  The colon can be trailed by optional directory and/or
9894        filename, but two consecutive colons indicates a nodename rather
9895        than a device.  [pr]  */
9896   if (*name == '_') ++name;
9897   if (tolower(*name++) != 'n') return 0;
9898   if (tolower(*name++) != 'l') return 0;
9899   if (tolower(*name) == 'a') ++name;
9900   if (*name == '0') ++name;
9901   return (*name++ == ':') && (*name != ':');
9902 }
9903
9904
9905 static I32
9906 Perl_cando_by_name_int
9907    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
9908 {
9909   static char usrname[L_cuserid];
9910   static struct dsc$descriptor_s usrdsc =
9911          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
9912   char vmsname[NAM$C_MAXRSS+1];
9913   char *fileified;
9914   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
9915   unsigned short int retlen, trnlnm_iter_count;
9916   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9917   union prvdef curprv;
9918   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9919          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
9920          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
9921   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9922          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9923          {0,0,0,0}};
9924   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
9925          {0,0,0,0}};
9926   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9927
9928   if (!fname || !*fname) return FALSE;
9929   /* Make sure we expand logical names, since sys$check_access doesn't */
9930
9931   fileified = NULL;
9932   if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
9933     fileified = PerlMem_malloc(VMS_MAXRSS);
9934     if (!strpbrk(fname,"/]>:")) {
9935       strcpy(fileified,fname);
9936       trnlnm_iter_count = 0;
9937       while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
9938         trnlnm_iter_count++;
9939         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
9940       }
9941       fname = fileified;
9942     }
9943     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS)) {
9944       PerlMem_free(fileified);
9945       return FALSE;
9946     }
9947     retlen = namdsc.dsc$w_length = strlen(vmsname);
9948     namdsc.dsc$a_pointer = vmsname;
9949     if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
9950       vmsname[retlen-1] == ':') {
9951       if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9952       namdsc.dsc$w_length = strlen(fileified);
9953       namdsc.dsc$a_pointer = fileified;
9954     }
9955   }
9956   else {
9957     retlen = namdsc.dsc$w_length = strlen(fname);
9958     namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
9959   }
9960
9961   switch (bit) {
9962     case S_IXUSR: case S_IXGRP: case S_IXOTH:
9963       access = ARM$M_EXECUTE;
9964       flags = CHP$M_READ;
9965       break;
9966     case S_IRUSR: case S_IRGRP: case S_IROTH:
9967       access = ARM$M_READ;
9968       flags = CHP$M_READ | CHP$M_USEREADALL;
9969       break;
9970     case S_IWUSR: case S_IWGRP: case S_IWOTH:
9971       access = ARM$M_WRITE;
9972       flags = CHP$M_READ | CHP$M_WRITE;
9973       break;
9974     case S_IDUSR: case S_IDGRP: case S_IDOTH:
9975       access = ARM$M_DELETE;
9976       flags = CHP$M_READ | CHP$M_WRITE;
9977       break;
9978     default:
9979       if (fileified != NULL)
9980         PerlMem_free(fileified);
9981       return FALSE;
9982   }
9983
9984   /* Before we call $check_access, create a user profile with the current
9985    * process privs since otherwise it just uses the default privs from the
9986    * UAF and might give false positives or negatives.  This only works on
9987    * VMS versions v6.0 and later since that's when sys$create_user_profile
9988    * became available.
9989    */
9990
9991   /* get current process privs and username */
9992   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9993   _ckvmssts(iosb[0]);
9994
9995 #if defined(__VMS_VER) && __VMS_VER >= 60000000
9996
9997   /* find out the space required for the profile */
9998   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
9999                                     &usrprodsc.dsc$w_length,0));
10000
10001   /* allocate space for the profile and get it filled in */
10002   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10003   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10004   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10005                                     &usrprodsc.dsc$w_length,0));
10006
10007   /* use the profile to check access to the file; free profile & analyze results */
10008   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10009   PerlMem_free(usrprodsc.dsc$a_pointer);
10010   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10011
10012 #else
10013
10014   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10015
10016 #endif
10017
10018   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
10019       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10020       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10021     set_vaxc_errno(retsts);
10022     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10023     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10024     else set_errno(ENOENT);
10025     if (fileified != NULL)
10026       PerlMem_free(fileified);
10027     return FALSE;
10028   }
10029   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10030     if (fileified != NULL)
10031       PerlMem_free(fileified);
10032     return TRUE;
10033   }
10034   _ckvmssts(retsts);
10035
10036   if (fileified != NULL)
10037     PerlMem_free(fileified);
10038   return FALSE;  /* Should never get here */
10039
10040 }
10041
10042 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
10043 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
10044  * subset of the applicable information.
10045  */
10046 bool
10047 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
10048 {
10049   return cando_by_name_int
10050         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
10051 }  /* end of cando() */
10052 /*}}}*/
10053
10054
10055 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10056 I32
10057 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10058 {
10059    return cando_by_name_int(bit, effective, fname, 0);
10060
10061 }  /* end of cando_by_name() */
10062 /*}}}*/
10063
10064
10065 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10066 int
10067 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10068 {
10069   if (!fstat(fd,(stat_t *) statbufp)) {
10070     char *cptr;
10071     char *vms_filename;
10072     vms_filename = PerlMem_malloc(VMS_MAXRSS);
10073     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
10074
10075     /* Save name for cando by name in VMS format */
10076     cptr = getname(fd, vms_filename, 1);
10077
10078     /* This should not happen, but just in case */
10079     if (cptr == NULL) {
10080         statbufp->st_devnam[0] = 0;
10081     }
10082     else {
10083         /* Make sure that the saved name fits in 255 characters */
10084         cptr = do_rmsexpand
10085                        (vms_filename,
10086                         statbufp->st_devnam,
10087                         0,
10088                         NULL,
10089                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN);
10090         if (cptr == NULL)
10091             statbufp->st_devnam[0] = 0;
10092     }
10093     PerlMem_free(vms_filename);
10094
10095     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10096     VMS_DEVICE_ENCODE
10097         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10098
10099 #   ifdef RTL_USES_UTC
10100 #   ifdef VMSISH_TIME
10101     if (VMSISH_TIME) {
10102       statbufp->st_mtime = _toloc(statbufp->st_mtime);
10103       statbufp->st_atime = _toloc(statbufp->st_atime);
10104       statbufp->st_ctime = _toloc(statbufp->st_ctime);
10105     }
10106 #   endif
10107 #   else
10108 #   ifdef VMSISH_TIME
10109     if (!VMSISH_TIME) { /* Return UTC instead of local time */
10110 #   else
10111     if (1) {
10112 #   endif
10113       statbufp->st_mtime = _toutc(statbufp->st_mtime);
10114       statbufp->st_atime = _toutc(statbufp->st_atime);
10115       statbufp->st_ctime = _toutc(statbufp->st_ctime);
10116     }
10117 #endif
10118     return 0;
10119   }
10120   return -1;
10121
10122 }  /* end of flex_fstat() */
10123 /*}}}*/
10124
10125 #if !defined(__VAX) && __CRTL_VER >= 80200000
10126 #ifdef lstat
10127 #undef lstat
10128 #endif
10129 #else
10130 #ifdef lstat
10131 #undef lstat
10132 #endif
10133 #define lstat(_x, _y) stat(_x, _y)
10134 #endif
10135
10136 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
10137
10138 static int
10139 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10140 {
10141     char fileified[VMS_MAXRSS];
10142     char temp_fspec[VMS_MAXRSS];
10143     char *save_spec;
10144     int retval = -1;
10145     int saved_errno, saved_vaxc_errno;
10146
10147     if (!fspec) return retval;
10148     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10149     strcpy(temp_fspec, fspec);
10150
10151     if (decc_bug_devnull != 0) {
10152       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10153         memset(statbufp,0,sizeof *statbufp);
10154         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
10155         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10156         statbufp->st_uid = 0x00010001;
10157         statbufp->st_gid = 0x0001;
10158         time((time_t *)&statbufp->st_mtime);
10159         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10160         return 0;
10161       }
10162     }
10163
10164     /* Try for a directory name first.  If fspec contains a filename without
10165      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10166      * and sea:[wine.dark]water. exist, we prefer the directory here.
10167      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10168      * not sea:[wine.dark]., if the latter exists.  If the intended target is
10169      * the file with null type, specify this by calling flex_stat() with
10170      * a '.' at the end of fspec.
10171      *
10172      * If we are in Posix filespec mode, accept the filename as is.
10173      */
10174 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10175   if (decc_posix_compliant_pathnames == 0) {
10176 #endif
10177     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
10178       if (lstat_flag == 0)
10179         retval = stat(fileified,(stat_t *) statbufp);
10180       else
10181         retval = lstat(fileified,(stat_t *) statbufp);
10182       save_spec = fileified;
10183     }
10184     if (retval) {
10185       if (lstat_flag == 0)
10186         retval = stat(temp_fspec,(stat_t *) statbufp);
10187       else
10188         retval = lstat(temp_fspec,(stat_t *) statbufp);
10189       save_spec = temp_fspec;
10190     }
10191 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10192   } else {
10193     if (lstat_flag == 0)
10194       retval = stat(temp_fspec,(stat_t *) statbufp);
10195     else
10196       retval = lstat(temp_fspec,(stat_t *) statbufp);
10197       save_spec = temp_fspec;
10198   }
10199 #endif
10200     if (!retval) {
10201     char * cptr;
10202       cptr = do_rmsexpand
10203             (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS);
10204       if (cptr == NULL)
10205         statbufp->st_devnam[0] = 0;
10206
10207       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10208       VMS_DEVICE_ENCODE
10209         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10210 #     ifdef RTL_USES_UTC
10211 #     ifdef VMSISH_TIME
10212       if (VMSISH_TIME) {
10213         statbufp->st_mtime = _toloc(statbufp->st_mtime);
10214         statbufp->st_atime = _toloc(statbufp->st_atime);
10215         statbufp->st_ctime = _toloc(statbufp->st_ctime);
10216       }
10217 #     endif
10218 #     else
10219 #     ifdef VMSISH_TIME
10220       if (!VMSISH_TIME) { /* Return UTC instead of local time */
10221 #     else
10222       if (1) {
10223 #     endif
10224         statbufp->st_mtime = _toutc(statbufp->st_mtime);
10225         statbufp->st_atime = _toutc(statbufp->st_atime);
10226         statbufp->st_ctime = _toutc(statbufp->st_ctime);
10227       }
10228 #     endif
10229     }
10230     /* If we were successful, leave errno where we found it */
10231     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10232     return retval;
10233
10234 }  /* end of flex_stat_int() */
10235
10236
10237 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10238 int
10239 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10240 {
10241    return flex_stat_int(fspec, statbufp, 0);
10242 }
10243 /*}}}*/
10244
10245 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10246 int
10247 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10248 {
10249    return flex_stat_int(fspec, statbufp, 1);
10250 }
10251 /*}}}*/
10252
10253
10254 /*{{{char *my_getlogin()*/
10255 /* VMS cuserid == Unix getlogin, except calling sequence */
10256 char *
10257 my_getlogin(void)
10258 {
10259     static char user[L_cuserid];
10260     return cuserid(user);
10261 }
10262 /*}}}*/
10263
10264
10265 /*  rmscopy - copy a file using VMS RMS routines
10266  *
10267  *  Copies contents and attributes of spec_in to spec_out, except owner
10268  *  and protection information.  Name and type of spec_in are used as
10269  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
10270  *  should try to propagate timestamps from the input file to the output file.
10271  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
10272  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
10273  *  propagated to the output file at creation iff the output file specification
10274  *  did not contain an explicit name or type, and the revision date is always
10275  *  updated at the end of the copy operation.  If it is greater than 0, then
10276  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
10277  *  other than the revision date should be propagated, and bit 1 indicates
10278  *  that the revision date should be propagated.
10279  *
10280  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
10281  *
10282  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
10283  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
10284  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
10285  * as part of the Perl standard distribution under the terms of the
10286  * GNU General Public License or the Perl Artistic License.  Copies
10287  * of each may be found in the Perl standard distribution.
10288  */ /* FIXME */
10289 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
10290 int
10291 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10292 {
10293     char *vmsin, * vmsout, *esa, *esa_out,
10294          *rsa, *ubf;
10295     unsigned long int i, sts, sts2;
10296     int dna_len;
10297     struct FAB fab_in, fab_out;
10298     struct RAB rab_in, rab_out;
10299     rms_setup_nam(nam);
10300     rms_setup_nam(nam_out);
10301     struct XABDAT xabdat;
10302     struct XABFHC xabfhc;
10303     struct XABRDT xabrdt;
10304     struct XABSUM xabsum;
10305
10306     vmsin = PerlMem_malloc(VMS_MAXRSS);
10307     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
10308     vmsout = PerlMem_malloc(VMS_MAXRSS);
10309     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
10310     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
10311         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10312       PerlMem_free(vmsin);
10313       PerlMem_free(vmsout);
10314       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10315       return 0;
10316     }
10317
10318     esa = PerlMem_malloc(VMS_MAXRSS);
10319     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
10320     fab_in = cc$rms_fab;
10321     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
10322     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10323     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10324     fab_in.fab$l_fop = FAB$M_SQO;
10325     rms_bind_fab_nam(fab_in, nam);
10326     fab_in.fab$l_xab = (void *) &xabdat;
10327
10328     rsa = PerlMem_malloc(VMS_MAXRSS);
10329     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
10330     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
10331     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
10332     rms_nam_esl(nam) = 0;
10333     rms_nam_rsl(nam) = 0;
10334     rms_nam_esll(nam) = 0;
10335     rms_nam_rsll(nam) = 0;
10336 #ifdef NAM$M_NO_SHORT_UPCASE
10337     if (decc_efs_case_preserve)
10338         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
10339 #endif
10340
10341     xabdat = cc$rms_xabdat;        /* To get creation date */
10342     xabdat.xab$l_nxt = (void *) &xabfhc;
10343
10344     xabfhc = cc$rms_xabfhc;        /* To get record length */
10345     xabfhc.xab$l_nxt = (void *) &xabsum;
10346
10347     xabsum = cc$rms_xabsum;        /* To get key and area information */
10348
10349     if (!((sts = sys$open(&fab_in)) & 1)) {
10350       PerlMem_free(vmsin);
10351       PerlMem_free(vmsout);
10352       PerlMem_free(esa);
10353       PerlMem_free(rsa);
10354       set_vaxc_errno(sts);
10355       switch (sts) {
10356         case RMS$_FNF: case RMS$_DNF:
10357           set_errno(ENOENT); break;
10358         case RMS$_DIR:
10359           set_errno(ENOTDIR); break;
10360         case RMS$_DEV:
10361           set_errno(ENODEV); break;
10362         case RMS$_SYN:
10363           set_errno(EINVAL); break;
10364         case RMS$_PRV:
10365           set_errno(EACCES); break;
10366         default:
10367           set_errno(EVMSERR);
10368       }
10369       return 0;
10370     }
10371
10372     nam_out = nam;
10373     fab_out = fab_in;
10374     fab_out.fab$w_ifi = 0;
10375     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10376     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10377     fab_out.fab$l_fop = FAB$M_SQO;
10378     rms_bind_fab_nam(fab_out, nam_out);
10379     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
10380     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
10381     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
10382     esa_out = PerlMem_malloc(VMS_MAXRSS);
10383     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
10384     rms_set_rsa(nam_out, NULL, 0);
10385     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
10386
10387     if (preserve_dates == 0) {  /* Act like DCL COPY */
10388       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
10389       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10390       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
10391         PerlMem_free(vmsin);
10392         PerlMem_free(vmsout);
10393         PerlMem_free(esa);
10394         PerlMem_free(rsa);
10395         PerlMem_free(esa_out);
10396         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10397         set_vaxc_errno(sts);
10398         return 0;
10399       }
10400       fab_out.fab$l_xab = (void *) &xabdat;
10401       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
10402         preserve_dates = 1;
10403     }
10404     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10405       preserve_dates =0;      /* bitmask from this point forward   */
10406
10407     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10408     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
10409       PerlMem_free(vmsin);
10410       PerlMem_free(vmsout);
10411       PerlMem_free(esa);
10412       PerlMem_free(rsa);
10413       PerlMem_free(esa_out);
10414       set_vaxc_errno(sts);
10415       switch (sts) {
10416         case RMS$_DNF:
10417           set_errno(ENOENT); break;
10418         case RMS$_DIR:
10419           set_errno(ENOTDIR); break;
10420         case RMS$_DEV:
10421           set_errno(ENODEV); break;
10422         case RMS$_SYN:
10423           set_errno(EINVAL); break;
10424         case RMS$_PRV:
10425           set_errno(EACCES); break;
10426         default:
10427           set_errno(EVMSERR);
10428       }
10429       return 0;
10430     }
10431     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10432     if (preserve_dates & 2) {
10433       /* sys$close() will process xabrdt, not xabdat */
10434       xabrdt = cc$rms_xabrdt;
10435 #ifndef __GNUC__
10436       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10437 #else
10438       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10439        * is unsigned long[2], while DECC & VAXC use a struct */
10440       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10441 #endif
10442       fab_out.fab$l_xab = (void *) &xabrdt;
10443     }
10444
10445     ubf = PerlMem_malloc(32256);
10446     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
10447     rab_in = cc$rms_rab;
10448     rab_in.rab$l_fab = &fab_in;
10449     rab_in.rab$l_rop = RAB$M_BIO;
10450     rab_in.rab$l_ubf = ubf;
10451     rab_in.rab$w_usz = 32256;
10452     if (!((sts = sys$connect(&rab_in)) & 1)) {
10453       sys$close(&fab_in); sys$close(&fab_out);
10454       PerlMem_free(vmsin);
10455       PerlMem_free(vmsout);
10456       PerlMem_free(esa);
10457       PerlMem_free(ubf);
10458       PerlMem_free(rsa);
10459       PerlMem_free(esa_out);
10460       set_errno(EVMSERR); set_vaxc_errno(sts);
10461       return 0;
10462     }
10463
10464     rab_out = cc$rms_rab;
10465     rab_out.rab$l_fab = &fab_out;
10466     rab_out.rab$l_rbf = ubf;
10467     if (!((sts = sys$connect(&rab_out)) & 1)) {
10468       sys$close(&fab_in); sys$close(&fab_out);
10469       PerlMem_free(vmsin);
10470       PerlMem_free(vmsout);
10471       PerlMem_free(esa);
10472       PerlMem_free(ubf);
10473       PerlMem_free(rsa);
10474       PerlMem_free(esa_out);
10475       set_errno(EVMSERR); set_vaxc_errno(sts);
10476       return 0;
10477     }
10478
10479     while ((sts = sys$read(&rab_in))) {  /* always true  */
10480       if (sts == RMS$_EOF) break;
10481       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10482       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10483         sys$close(&fab_in); sys$close(&fab_out);
10484         PerlMem_free(vmsin);
10485         PerlMem_free(vmsout);
10486         PerlMem_free(esa);
10487         PerlMem_free(ubf);
10488         PerlMem_free(rsa);
10489         PerlMem_free(esa_out);
10490         set_errno(EVMSERR); set_vaxc_errno(sts);
10491         return 0;
10492       }
10493     }
10494
10495
10496     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10497     sys$close(&fab_in);  sys$close(&fab_out);
10498     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10499     if (!(sts & 1)) {
10500       PerlMem_free(vmsin);
10501       PerlMem_free(vmsout);
10502       PerlMem_free(esa);
10503       PerlMem_free(ubf);
10504       PerlMem_free(rsa);
10505       PerlMem_free(esa_out);
10506       set_errno(EVMSERR); set_vaxc_errno(sts);
10507       return 0;
10508     }
10509
10510     PerlMem_free(vmsin);
10511     PerlMem_free(vmsout);
10512     PerlMem_free(esa);
10513     PerlMem_free(ubf);
10514     PerlMem_free(rsa);
10515     PerlMem_free(esa_out);
10516     return 1;
10517
10518 }  /* end of rmscopy() */
10519 /*}}}*/
10520
10521
10522 /***  The following glue provides 'hooks' to make some of the routines
10523  * from this file available from Perl.  These routines are sufficiently
10524  * basic, and are required sufficiently early in the build process,
10525  * that's it's nice to have them available to miniperl as well as the
10526  * full Perl, so they're set up here instead of in an extension.  The
10527  * Perl code which handles importation of these names into a given
10528  * package lives in [.VMS]Filespec.pm in @INC.
10529  */
10530
10531 void
10532 rmsexpand_fromperl(pTHX_ CV *cv)
10533 {
10534   dXSARGS;
10535   char *fspec, *defspec = NULL, *rslt;
10536   STRLEN n_a;
10537
10538   if (!items || items > 2)
10539     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10540   fspec = SvPV(ST(0),n_a);
10541   if (!fspec || !*fspec) XSRETURN_UNDEF;
10542   if (items == 2) defspec = SvPV(ST(1),n_a);
10543
10544   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10545   ST(0) = sv_newmortal();
10546   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10547   XSRETURN(1);
10548 }
10549
10550 void
10551 vmsify_fromperl(pTHX_ CV *cv)
10552 {
10553   dXSARGS;
10554   char *vmsified;
10555   STRLEN n_a;
10556
10557   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10558   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10559   ST(0) = sv_newmortal();
10560   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10561   XSRETURN(1);
10562 }
10563
10564 void
10565 unixify_fromperl(pTHX_ CV *cv)
10566 {
10567   dXSARGS;
10568   char *unixified;
10569   STRLEN n_a;
10570
10571   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10572   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10573   ST(0) = sv_newmortal();
10574   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10575   XSRETURN(1);
10576 }
10577
10578 void
10579 fileify_fromperl(pTHX_ CV *cv)
10580 {
10581   dXSARGS;
10582   char *fileified;
10583   STRLEN n_a;
10584
10585   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10586   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10587   ST(0) = sv_newmortal();
10588   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10589   XSRETURN(1);
10590 }
10591
10592 void
10593 pathify_fromperl(pTHX_ CV *cv)
10594 {
10595   dXSARGS;
10596   char *pathified;
10597   STRLEN n_a;
10598
10599   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10600   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10601   ST(0) = sv_newmortal();
10602   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10603   XSRETURN(1);
10604 }
10605
10606 void
10607 vmspath_fromperl(pTHX_ CV *cv)
10608 {
10609   dXSARGS;
10610   char *vmspath;
10611   STRLEN n_a;
10612
10613   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10614   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10615   ST(0) = sv_newmortal();
10616   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10617   XSRETURN(1);
10618 }
10619
10620 void
10621 unixpath_fromperl(pTHX_ CV *cv)
10622 {
10623   dXSARGS;
10624   char *unixpath;
10625   STRLEN n_a;
10626
10627   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10628   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10629   ST(0) = sv_newmortal();
10630   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10631   XSRETURN(1);
10632 }
10633
10634 void
10635 candelete_fromperl(pTHX_ CV *cv)
10636 {
10637   dXSARGS;
10638   char *fspec, *fsp;
10639   SV *mysv;
10640   IO *io;
10641   STRLEN n_a;
10642
10643   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10644
10645   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10646   Newx(fspec, VMS_MAXRSS, char);
10647   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
10648   if (SvTYPE(mysv) == SVt_PVGV) {
10649     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10650       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10651       ST(0) = &PL_sv_no;
10652       Safefree(fspec);
10653       XSRETURN(1);
10654     }
10655     fsp = fspec;
10656   }
10657   else {
10658     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10659       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10660       ST(0) = &PL_sv_no;
10661       Safefree(fspec);
10662       XSRETURN(1);
10663     }
10664   }
10665
10666   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10667   Safefree(fspec);
10668   XSRETURN(1);
10669 }
10670
10671 void
10672 rmscopy_fromperl(pTHX_ CV *cv)
10673 {
10674   dXSARGS;
10675   char *inspec, *outspec, *inp, *outp;
10676   int date_flag;
10677   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10678                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10679   unsigned long int sts;
10680   SV *mysv;
10681   IO *io;
10682   STRLEN n_a;
10683
10684   if (items < 2 || items > 3)
10685     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10686
10687   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10688   Newx(inspec, VMS_MAXRSS, char);
10689   if (SvTYPE(mysv) == SVt_PVGV) {
10690     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10691       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10692       ST(0) = &PL_sv_no;
10693       Safefree(inspec);
10694       XSRETURN(1);
10695     }
10696     inp = inspec;
10697   }
10698   else {
10699     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10700       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10701       ST(0) = &PL_sv_no;
10702       Safefree(inspec);
10703       XSRETURN(1);
10704     }
10705   }
10706   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
10707   Newx(outspec, VMS_MAXRSS, char);
10708   if (SvTYPE(mysv) == SVt_PVGV) {
10709     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
10710       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10711       ST(0) = &PL_sv_no;
10712       Safefree(inspec);
10713       Safefree(outspec);
10714       XSRETURN(1);
10715     }
10716     outp = outspec;
10717   }
10718   else {
10719     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
10720       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10721       ST(0) = &PL_sv_no;
10722       Safefree(inspec);
10723       Safefree(outspec);
10724       XSRETURN(1);
10725     }
10726   }
10727   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
10728
10729   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
10730   Safefree(inspec);
10731   Safefree(outspec);
10732   XSRETURN(1);
10733 }
10734
10735 /* The mod2fname is limited to shorter filenames by design, so it should
10736  * not be modified to support longer EFS pathnames
10737  */
10738 void
10739 mod2fname(pTHX_ CV *cv)
10740 {
10741   dXSARGS;
10742   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10743        workbuff[NAM$C_MAXRSS*1 + 1];
10744   int total_namelen = 3, counter, num_entries;
10745   /* ODS-5 ups this, but we want to be consistent, so... */
10746   int max_name_len = 39;
10747   AV *in_array = (AV *)SvRV(ST(0));
10748
10749   num_entries = av_len(in_array);
10750
10751   /* All the names start with PL_. */
10752   strcpy(ultimate_name, "PL_");
10753
10754   /* Clean up our working buffer */
10755   Zero(work_name, sizeof(work_name), char);
10756
10757   /* Run through the entries and build up a working name */
10758   for(counter = 0; counter <= num_entries; counter++) {
10759     /* If it's not the first name then tack on a __ */
10760     if (counter) {
10761       strcat(work_name, "__");
10762     }
10763     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10764                            PL_na));
10765   }
10766
10767   /* Check to see if we actually have to bother...*/
10768   if (strlen(work_name) + 3 <= max_name_len) {
10769     strcat(ultimate_name, work_name);
10770   } else {
10771     /* It's too darned big, so we need to go strip. We use the same */
10772     /* algorithm as xsubpp does. First, strip out doubled __ */
10773     char *source, *dest, last;
10774     dest = workbuff;
10775     last = 0;
10776     for (source = work_name; *source; source++) {
10777       if (last == *source && last == '_') {
10778         continue;
10779       }
10780       *dest++ = *source;
10781       last = *source;
10782     }
10783     /* Go put it back */
10784     strcpy(work_name, workbuff);
10785     /* Is it still too big? */
10786     if (strlen(work_name) + 3 > max_name_len) {
10787       /* Strip duplicate letters */
10788       last = 0;
10789       dest = workbuff;
10790       for (source = work_name; *source; source++) {
10791         if (last == toupper(*source)) {
10792         continue;
10793         }
10794         *dest++ = *source;
10795         last = toupper(*source);
10796       }
10797       strcpy(work_name, workbuff);
10798     }
10799
10800     /* Is it *still* too big? */
10801     if (strlen(work_name) + 3 > max_name_len) {
10802       /* Too bad, we truncate */
10803       work_name[max_name_len - 2] = 0;
10804     }
10805     strcat(ultimate_name, work_name);
10806   }
10807
10808   /* Okay, return it */
10809   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10810   XSRETURN(1);
10811 }
10812
10813 void
10814 hushexit_fromperl(pTHX_ CV *cv)
10815 {
10816     dXSARGS;
10817
10818     if (items > 0) {
10819         VMSISH_HUSHED = SvTRUE(ST(0));
10820     }
10821     ST(0) = boolSV(VMSISH_HUSHED);
10822     XSRETURN(1);
10823 }
10824
10825
10826 PerlIO *
10827 Perl_vms_start_glob
10828    (pTHX_ SV *tmpglob,
10829     IO *io)
10830 {
10831     PerlIO *fp;
10832     struct vs_str_st *rslt;
10833     char *vmsspec;
10834     char *rstr;
10835     char *begin, *cp;
10836     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
10837     PerlIO *tmpfp;
10838     STRLEN i;
10839     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10840     struct dsc$descriptor_vs rsdsc;
10841     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
10842     unsigned long hasver = 0, isunix = 0;
10843     unsigned long int lff_flags = 0;
10844     int rms_sts;
10845
10846 #ifdef VMS_LONGNAME_SUPPORT
10847     lff_flags = LIB$M_FIL_LONG_NAMES;
10848 #endif
10849     /* The Newx macro will not allow me to assign a smaller array
10850      * to the rslt pointer, so we will assign it to the begin char pointer
10851      * and then copy the value into the rslt pointer.
10852      */
10853     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
10854     rslt = (struct vs_str_st *)begin;
10855     rslt->length = 0;
10856     rstr = &rslt->str[0];
10857     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
10858     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
10859     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
10860     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
10861
10862     Newx(vmsspec, VMS_MAXRSS, char);
10863
10864         /* We could find out if there's an explicit dev/dir or version
10865            by peeking into lib$find_file's internal context at
10866            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
10867            but that's unsupported, so I don't want to do it now and
10868            have it bite someone in the future. */
10869         /* Fix-me: vms_split_path() is the only way to do this, the
10870            existing method will fail with many legal EFS or UNIX specifications
10871          */
10872
10873     cp = SvPV(tmpglob,i);
10874
10875     for (; i; i--) {
10876         if (cp[i] == ';') hasver = 1;
10877         if (cp[i] == '.') {
10878             if (sts) hasver = 1;
10879             else sts = 1;
10880         }
10881         if (cp[i] == '/') {
10882             hasdir = isunix = 1;
10883             break;
10884         }
10885         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
10886             hasdir = 1;
10887             break;
10888         }
10889     }
10890     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
10891         Stat_t st;
10892         int stat_sts;
10893         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
10894         if (!stat_sts && S_ISDIR(st.st_mode)) {
10895             wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec);
10896             ok = (wilddsc.dsc$a_pointer != NULL);
10897         }
10898         else {
10899             wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec);
10900             ok = (wilddsc.dsc$a_pointer != NULL);
10901         }
10902         if (ok)
10903             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
10904
10905         /* If not extended character set, replace ? with % */
10906         /* With extended character set, ? is a wildcard single character */
10907         if (!decc_efs_case_preserve) {
10908             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
10909                 if (*cp == '?') *cp = '%';
10910         }
10911         sts = SS$_NORMAL;
10912         while (ok && $VMS_STATUS_SUCCESS(sts)) {
10913          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10914          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10915
10916             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
10917                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
10918             if (!$VMS_STATUS_SUCCESS(sts))
10919                 break;
10920
10921             /* with varying string, 1st word of buffer contains result length */
10922             rstr[rslt->length] = '\0';
10923
10924              /* Find where all the components are */
10925              v_sts = vms_split_path
10926                        (aTHX_ rstr,
10927                         &v_spec,
10928                         &v_len,
10929                         &r_spec,
10930                         &r_len,
10931                         &d_spec,
10932                         &d_len,
10933                         &n_spec,
10934                         &n_len,
10935                         &e_spec,
10936                         &e_len,
10937                         &vs_spec,
10938                         &vs_len);
10939
10940             /* If no version on input, truncate the version on output */
10941             if (!hasver && (vs_len > 0)) {
10942                 *vs_spec = '\0';
10943                 vs_len = 0;
10944
10945                 /* No version & a null extension on UNIX handling */
10946                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
10947                     e_len = 0;
10948                     *e_spec = '\0';
10949                 }
10950             }
10951
10952             if (!decc_efs_case_preserve) {
10953                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
10954             }
10955
10956             if (hasdir) {
10957                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
10958                 begin = rstr;
10959             }
10960             else {
10961                 /* Start with the name */
10962                 begin = n_spec;
10963             }
10964             strcat(begin,"\n");
10965             ok = (PerlIO_puts(tmpfp,begin) != EOF);
10966         }
10967         if (cxt) (void)lib$find_file_end(&cxt);
10968         if (ok && sts != RMS$_NMF &&
10969             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
10970         if (!ok) {
10971             if (!(sts & 1)) {
10972                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
10973             }
10974             PerlIO_close(tmpfp);
10975             fp = NULL;
10976         }
10977         else {
10978             PerlIO_rewind(tmpfp);
10979             IoTYPE(io) = IoTYPE_RDONLY;
10980             IoIFP(io) = fp = tmpfp;
10981             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
10982         }
10983     }
10984     Safefree(vmsspec);
10985     Safefree(rslt);
10986     return fp;
10987 }
10988
10989 #ifdef HAS_SYMLINK
10990 static char *
10991 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10992
10993 void
10994 vms_realpath_fromperl(pTHX_ CV *cv)
10995 {
10996   dXSARGS;
10997   char *fspec, *rslt_spec, *rslt;
10998   STRLEN n_a;
10999
11000   if (!items || items != 1)
11001     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11002
11003   fspec = SvPV(ST(0),n_a);
11004   if (!fspec || !*fspec) XSRETURN_UNDEF;
11005
11006   Newx(rslt_spec, VMS_MAXRSS + 1, char);
11007   rslt = do_vms_realpath(fspec, rslt_spec);
11008   ST(0) = sv_newmortal();
11009   if (rslt != NULL)
11010     sv_usepvn(ST(0),rslt,strlen(rslt));
11011   else
11012     Safefree(rslt_spec);
11013   XSRETURN(1);
11014 }
11015 #endif
11016
11017 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11018 int do_vms_case_tolerant(void);
11019
11020 void
11021 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11022 {
11023   dXSARGS;
11024   ST(0) = boolSV(do_vms_case_tolerant());
11025   XSRETURN(1);
11026 }
11027 #endif
11028
11029 void
11030 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11031                           struct interp_intern *dst)
11032 {
11033     memcpy(dst,src,sizeof(struct interp_intern));
11034 }
11035
11036 void
11037 Perl_sys_intern_clear(pTHX)
11038 {
11039 }
11040
11041 void
11042 Perl_sys_intern_init(pTHX)
11043 {
11044     unsigned int ix = RAND_MAX;
11045     double x;
11046
11047     VMSISH_HUSHED = 0;
11048
11049     /* fix me later to track running under GNV */
11050     /* this allows some limited testing */
11051     MY_POSIX_EXIT = decc_filename_unix_report;
11052
11053     x = (float)ix;
11054     MY_INV_RAND_MAX = 1./x;
11055 }
11056
11057 void
11058 init_os_extras(void)
11059 {
11060   dTHX;
11061   char* file = __FILE__;
11062   if (decc_disable_to_vms_logname_translation) {
11063     no_translate_barewords = TRUE;
11064   } else {
11065     no_translate_barewords = FALSE;
11066   }
11067
11068   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11069   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11070   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11071   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11072   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11073   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11074   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11075   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11076   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11077   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11078   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11079 #ifdef HAS_SYMLINK
11080   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11081 #endif
11082 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11083   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11084 #endif
11085
11086   store_pipelocs(aTHX);         /* will redo any earlier attempts */
11087
11088   return;
11089 }
11090
11091 #ifdef HAS_SYMLINK
11092
11093 #if __CRTL_VER == 80200000
11094 /* This missed getting in to the DECC SDK for 8.2 */
11095 char *realpath(const char *file_name, char * resolved_name, ...);
11096 #endif
11097
11098 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11099 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11100  * The perl fallback routine to provide realpath() is not as efficient
11101  * on OpenVMS.
11102  */
11103 static char *
11104 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11105 {
11106     return realpath(filespec, outbuf);
11107 }
11108
11109 /*}}}*/
11110 /* External entry points */
11111 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11112 { return do_vms_realpath(filespec, outbuf); }
11113 #else
11114 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11115 { return NULL; }
11116 #endif
11117
11118
11119 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11120 /* case_tolerant */
11121
11122 /*{{{int do_vms_case_tolerant(void)*/
11123 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11124  * controlled by a process setting.
11125  */
11126 int do_vms_case_tolerant(void)
11127 {
11128     return vms_process_case_tolerant;
11129 }
11130 /*}}}*/
11131 /* External entry points */
11132 int Perl_vms_case_tolerant(void)
11133 { return do_vms_case_tolerant(); }
11134 #else
11135 int Perl_vms_case_tolerant(void)
11136 { return vms_process_case_tolerant; }
11137 #endif
11138
11139
11140  /* Start of DECC RTL Feature handling */
11141
11142 static int sys_trnlnm
11143    (const char * logname,
11144     char * value,
11145     int value_len)
11146 {
11147     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11148     const unsigned long attr = LNM$M_CASE_BLIND;
11149     struct dsc$descriptor_s name_dsc;
11150     int status;
11151     unsigned short result;
11152     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11153                                 {0, 0, 0, 0}};
11154
11155     name_dsc.dsc$w_length = strlen(logname);
11156     name_dsc.dsc$a_pointer = (char *)logname;
11157     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11158     name_dsc.dsc$b_class = DSC$K_CLASS_S;
11159
11160     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11161
11162     if ($VMS_STATUS_SUCCESS(status)) {
11163
11164          /* Null terminate and return the string */
11165         /*--------------------------------------*/
11166         value[result] = 0;
11167     }
11168
11169     return status;
11170 }
11171
11172 static int sys_crelnm
11173    (const char * logname,
11174     const char * value)
11175 {
11176     int ret_val;
11177     const char * proc_table = "LNM$PROCESS_TABLE";
11178     struct dsc$descriptor_s proc_table_dsc;
11179     struct dsc$descriptor_s logname_dsc;
11180     struct itmlst_3 item_list[2];
11181
11182     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11183     proc_table_dsc.dsc$w_length = strlen(proc_table);
11184     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11185     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11186
11187     logname_dsc.dsc$a_pointer = (char *) logname;
11188     logname_dsc.dsc$w_length = strlen(logname);
11189     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11190     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11191
11192     item_list[0].buflen = strlen(value);
11193     item_list[0].itmcode = LNM$_STRING;
11194     item_list[0].bufadr = (char *)value;
11195     item_list[0].retlen = NULL;
11196
11197     item_list[1].buflen = 0;
11198     item_list[1].itmcode = 0;
11199
11200     ret_val = sys$crelnm
11201                        (NULL,
11202                         (const struct dsc$descriptor_s *)&proc_table_dsc,
11203                         (const struct dsc$descriptor_s *)&logname_dsc,
11204                         NULL,
11205                         (const struct item_list_3 *) item_list);
11206
11207     return ret_val;
11208 }
11209
11210
11211 /* C RTL Feature settings */
11212
11213 static int set_features
11214    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
11215     int (* cli_routine)(void),  /* Not documented */
11216     void *image_info)           /* Not documented */
11217 {
11218     int status;
11219     int s;
11220     int dflt;
11221     char* str;
11222     char val_str[10];
11223 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11224     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
11225     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
11226     unsigned long case_perm;
11227     unsigned long case_image;
11228 #endif
11229
11230     /* Allow an exception to bring Perl into the VMS debugger */
11231     vms_debug_on_exception = 0;
11232     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
11233     if ($VMS_STATUS_SUCCESS(status)) {
11234        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11235          vms_debug_on_exception = 1;
11236        else
11237          vms_debug_on_exception = 0;
11238     }
11239
11240
11241     /* hacks to see if known bugs are still present for testing */
11242
11243     /* Readdir is returning filenames in VMS syntax always */
11244     decc_bug_readdir_efs1 = 1;
11245     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
11246     if ($VMS_STATUS_SUCCESS(status)) {
11247        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11248          decc_bug_readdir_efs1 = 1;
11249        else
11250          decc_bug_readdir_efs1 = 0;
11251     }
11252
11253     /* PCP mode requires creating /dev/null special device file */
11254     decc_bug_devnull = 0;
11255     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
11256     if ($VMS_STATUS_SUCCESS(status)) {
11257        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11258           decc_bug_devnull = 1;
11259        else
11260           decc_bug_devnull = 0;
11261     }
11262
11263     /* fgetname returning a VMS name in UNIX mode */
11264     decc_bug_fgetname = 1;
11265     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
11266     if ($VMS_STATUS_SUCCESS(status)) {
11267       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11268         decc_bug_fgetname = 1;
11269       else
11270         decc_bug_fgetname = 0;
11271     }
11272
11273     /* UNIX directory names with no paths are broken in a lot of places */
11274     decc_dir_barename = 1;
11275     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
11276     if ($VMS_STATUS_SUCCESS(status)) {
11277       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11278         decc_dir_barename = 1;
11279       else
11280         decc_dir_barename = 0;
11281     }
11282
11283 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11284     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
11285     if (s >= 0) {
11286         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
11287         if (decc_disable_to_vms_logname_translation < 0)
11288             decc_disable_to_vms_logname_translation = 0;
11289     }
11290
11291     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
11292     if (s >= 0) {
11293         decc_efs_case_preserve = decc$feature_get_value(s, 1);
11294         if (decc_efs_case_preserve < 0)
11295             decc_efs_case_preserve = 0;
11296     }
11297
11298     s = decc$feature_get_index("DECC$EFS_CHARSET");
11299     if (s >= 0) {
11300         decc_efs_charset = decc$feature_get_value(s, 1);
11301         if (decc_efs_charset < 0)
11302             decc_efs_charset = 0;
11303     }
11304
11305     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
11306     if (s >= 0) {
11307         decc_filename_unix_report = decc$feature_get_value(s, 1);
11308         if (decc_filename_unix_report > 0)
11309             decc_filename_unix_report = 1;
11310         else
11311             decc_filename_unix_report = 0;
11312     }
11313
11314     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
11315     if (s >= 0) {
11316         decc_filename_unix_only = decc$feature_get_value(s, 1);
11317         if (decc_filename_unix_only > 0) {
11318             decc_filename_unix_only = 1;
11319         }
11320         else {
11321             decc_filename_unix_only = 0;
11322         }
11323     }
11324
11325     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
11326     if (s >= 0) {
11327         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
11328         if (decc_filename_unix_no_version < 0)
11329             decc_filename_unix_no_version = 0;
11330     }
11331
11332     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
11333     if (s >= 0) {
11334         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
11335         if (decc_readdir_dropdotnotype < 0)
11336             decc_readdir_dropdotnotype = 0;
11337     }
11338
11339     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
11340     if ($VMS_STATUS_SUCCESS(status)) {
11341         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
11342         if (s >= 0) {
11343             dflt = decc$feature_get_value(s, 4);
11344             if (dflt > 0) {
11345                 decc_disable_posix_root = decc$feature_get_value(s, 1);
11346                 if (decc_disable_posix_root <= 0) {
11347                     decc$feature_set_value(s, 1, 1);
11348                     decc_disable_posix_root = 1;
11349                 }
11350             }
11351             else {
11352                 /* Traditionally Perl assumes this is off */
11353                 decc_disable_posix_root = 1;
11354                 decc$feature_set_value(s, 1, 1);
11355             }
11356         }
11357     }
11358
11359 #if __CRTL_VER >= 80200000
11360     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
11361     if (s >= 0) {
11362         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11363         if (decc_posix_compliant_pathnames < 0)
11364             decc_posix_compliant_pathnames = 0;
11365         if (decc_posix_compliant_pathnames > 4)
11366             decc_posix_compliant_pathnames = 0;
11367     }
11368
11369 #endif
11370 #else
11371     status = sys_trnlnm
11372         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11373     if ($VMS_STATUS_SUCCESS(status)) {
11374         val_str[0] = _toupper(val_str[0]);
11375         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11376            decc_disable_to_vms_logname_translation = 1;
11377         }
11378     }
11379
11380 #ifndef __VAX
11381     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11382     if ($VMS_STATUS_SUCCESS(status)) {
11383         val_str[0] = _toupper(val_str[0]);
11384         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11385            decc_efs_case_preserve = 1;
11386         }
11387     }
11388 #endif
11389
11390     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11391     if ($VMS_STATUS_SUCCESS(status)) {
11392         val_str[0] = _toupper(val_str[0]);
11393         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11394            decc_filename_unix_report = 1;
11395         }
11396     }
11397     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11398     if ($VMS_STATUS_SUCCESS(status)) {
11399         val_str[0] = _toupper(val_str[0]);
11400         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11401            decc_filename_unix_only = 1;
11402            decc_filename_unix_report = 1;
11403         }
11404     }
11405     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11406     if ($VMS_STATUS_SUCCESS(status)) {
11407         val_str[0] = _toupper(val_str[0]);
11408         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11409            decc_filename_unix_no_version = 1;
11410         }
11411     }
11412     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11413     if ($VMS_STATUS_SUCCESS(status)) {
11414         val_str[0] = _toupper(val_str[0]);
11415         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11416            decc_readdir_dropdotnotype = 1;
11417         }
11418     }
11419 #endif
11420
11421 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11422
11423      /* Report true case tolerance */
11424     /*----------------------------*/
11425     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11426     if (!$VMS_STATUS_SUCCESS(status))
11427         case_perm = PPROP$K_CASE_BLIND;
11428     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11429     if (!$VMS_STATUS_SUCCESS(status))
11430         case_image = PPROP$K_CASE_BLIND;
11431     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11432         (case_image == PPROP$K_CASE_SENSITIVE))
11433         vms_process_case_tolerant = 0;
11434
11435 #endif
11436
11437
11438     /* CRTL can be initialized past this point, but not before. */
11439 /*    DECC$CRTL_INIT(); */
11440
11441     return SS$_NORMAL;
11442 }
11443
11444 #ifdef __DECC
11445 /* DECC dependent attributes */
11446 #if __DECC_VER < 60560002
11447 #define relative
11448 #define not_executable
11449 #else
11450 #define relative ,rel
11451 #define not_executable ,noexe
11452 #endif
11453 #pragma nostandard
11454 #pragma extern_model save
11455 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11456 #endif
11457         const __align (LONGWORD) int spare[8] = {0};
11458 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11459 /*                        NOWRT, LONG */
11460 #ifdef __DECC
11461 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11462         nowrt,noshr relative not_executable
11463 #endif
11464 const long vms_cc_features = (const long)set_features;
11465
11466 /*
11467 ** Force a reference to LIB$INITIALIZE to ensure it
11468 ** exists in the image.
11469 */
11470 int lib$initialize(void);
11471 #ifdef __DECC
11472 #pragma extern_model strict_refdef
11473 #endif
11474     int lib_init_ref = (int) lib$initialize;
11475
11476 #ifdef __DECC
11477 #pragma extern_model restore
11478 #pragma standard
11479 #endif
11480
11481 /*  End of vms.c */