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