vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  * Version: 5.7.0
   5  *
   6  * August 2005 Convert VMS status code to UNIX status codes
   7  * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
   8  *             and Perl_cando by Craig Berry
   9  * 29-Aug-2000 Charles Lane's piping improvements rolled in
  10  * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  11  */
  12
  13 #include <acedef.h>
  14 #include <acldef.h>
  15 #include <armdef.h>
  16 #include <atrdef.h>
  17 #include <chpdef.h>
  18 #include <clidef.h>
  19 #include <climsgdef.h>
  20 #include <descrip.h>
  21 #include <devdef.h>
  22 #include <dvidef.h>
  23 #include <fibdef.h>
  24 #include <float.h>
  25 #include <fscndef.h>
  26 #include <iodef.h>
  27 #include <jpidef.h>
  28 #include <kgbdef.h>
  29 #include <libclidef.h>
  30 #include <libdef.h>
  31 #include <lib$routines.h>
  32 #include <lnmdef.h>
  33 #include <msgdef.h>
  34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  35 #include <ppropdef.h>
  36 #endif
  37 #include <prvdef.h>
  38 #include <psldef.h>
  39 #include <rms.h>
  40 #include <shrdef.h>
  41 #include <ssdef.h>
  42 #include <starlet.h>
  43 #include <strdef.h>
  44 #include <str$routines.h>
  45 #include <syidef.h>
  46 #include <uaidef.h>
  47 #include <uicdef.h>
  48 #include <stsdef.h>
  49 #include <rmsdef.h>
  50
  51 /* Set the maximum filespec size here as it is larger for EFS file
  52  * specifications.
  53  * Not fully implemented at this time because the larger size
  54  * will likely impact the stack local storage requirements of
  55  * threaded code, and probably cause hard to diagnose failures.
  56  * To implement the larger sizes, all places where filename
  57  * storage is put on the stack need to be changed to use
  58  * New()/SafeFree() instead.
  59  */
  60 #ifndef __VAX
  61 #ifndef VMS_MAXRSS
  62 #ifdef NAML$C_MAXRSS
  63 #define VMS_MAXRSS (NAML$C_MAXRSS+1)
  64 #ifndef VMS_LONGNAME_SUPPORT
  65 #define VMS_LONGNAME_SUPPORT 1
  66 #endif /* VMS_LONGNAME_SUPPORT */
  67 #endif /* NAML$C_MAXRSS */
  68 #endif /* VMS_MAXRSS */
  69 #endif
  70
  71 /* temporary hack until support is complete */
  72 #ifdef VMS_LONGNAME_SUPPORT
  73 #undef VMS_LONGNAME_SUPPORT
  74 #undef VMS_MAXRSS
  75 #endif
  76 /* end of temporary hack until support is complete */
  77
  78 #ifndef VMS_MAXRSS
  79 #define VMS_MAXRSS (NAM$C_MAXRSS + 1)
  80 #endif
  81
  82 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  83 int   decc$feature_get_index(const char *name);
  84 char* decc$feature_get_name(int index);
  85 int   decc$feature_get_value(int index, int mode);
  86 int   decc$feature_set_value(int index, int mode, int value);
  87 #else
  88 #include <unixlib.h>
  89 #endif
  90
  91 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  92
  93 static int set_feature_default(const char *name, int value)
  94 {
  95     int status;
  96     int index;
  97
  98     index = decc$feature_get_index(name);
  99
 100     status = decc$feature_set_value(index, 1, value);
 101     if (index == -1 || (status == -1)) {
 102       return -1;
 103     }
 104
 105     status = decc$feature_get_value(index, 1);
 106     if (status != value) {
 107       return -1;
 108     }
 109
 110 return 0;
 111 }
 112 #endif
 113
 114 /* Older versions of ssdef.h don't have these */
 115 #ifndef SS$_INVFILFOROP
 116 #  define SS$_INVFILFOROP 3930
 117 #endif
 118 #ifndef SS$_NOSUCHOBJECT
 119 #  define SS$_NOSUCHOBJECT 2696
 120 #endif
 121
 122 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 123 #define PERLIO_NOT_STDIO 0
 124
 125 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 126  * code below needs to get to the underlying CRTL routines. */
 127 #define DONT_MASK_RTL_CALLS
 128 #include "EXTERN.h"
 129 #include "perl.h"
 130 #include "XSUB.h"
 131 /* Anticipating future expansion in lexical warnings . . . */
 132 #ifndef WARN_INTERNAL
 133 #  define WARN_INTERNAL WARN_MISC
 134 #endif
 135
 136 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 137 #  define RTL_USES_UTC 1
 138 #endif
 139
 140
 141 /* gcc's header files don't #define direct access macros
 142  * corresponding to VAXC's variant structs */
 143 #ifdef __GNUC__
 144 #  define uic$v_format uic$r_uic_form.uic$v_format
 145 #  define uic$v_group uic$r_uic_form.uic$v_group
 146 #  define uic$v_member uic$r_uic_form.uic$v_member
 147 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 148 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 149 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 150 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 151 #endif
 152
 153 #if defined(NEED_AN_H_ERRNO)
 154 dEXT int h_errno;
 155 #endif
 156
 157 #ifdef __DECC
 158 #pragma message disable pragma
 159 #pragma member_alignment save
 160 #pragma nomember_alignment longword
 161 #pragma message save
 162 #pragma message disable misalgndmem
 163 #endif
 164 struct itmlst_3 {
 165   unsigned short int buflen;
 166   unsigned short int itmcode;
 167   void *bufadr;
 168   unsigned short int *retlen;
 169 };
 170
 171 struct filescan_itmlst_2 {
 172     unsigned short length;
 173     unsigned short itmcode;
 174     char * component;
 175 };
 176
 177 #ifdef __DECC
 178 #pragma message restore
 179 #pragma member_alignment restore
 180 #endif
 181
 182 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
 183 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
 184 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
 185 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
 186 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
 187 #define do_vms_realpath(a,b)            mp_do_vms_realpath(aTHX_ a,b)
 188 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
 189 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
 190 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 191 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 192 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 193
 194 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
 195 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
 196 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
 197 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
 198
 199 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 200 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 201
 202 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 203  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 204  * the Perl facility.
 205  */
 206 #define PERL_LNM_MAX_ITER 10
 207
 208   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 209 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 210 #define MAX_DCL_SYMBOL          (8192)
 211 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 212 #else
 213 #define MAX_DCL_SYMBOL          (1024)
 214 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 215 #endif
 216
 217 static char *__mystrtolower(char *str)
 218 {
 219   if (str) for (; *str; ++str) *str= tolower(*str);
 220   return str;
 221 }
 222
 223 static struct dsc$descriptor_s fildevdsc =
 224   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 225 static struct dsc$descriptor_s crtlenvdsc =
 226   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 227 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 228 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 229 static struct dsc$descriptor_s **env_tables = defenv;
 230 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 231
 232 /* True if we shouldn't treat barewords as logicals during directory */
 233 /* munching */
 234 static int no_translate_barewords;
 235
 236 #ifndef RTL_USES_UTC
 237 static int tz_updated = 1;
 238 #endif
 239
 240 /* DECC Features that may need to affect how Perl interprets
 241  * displays filename information
 242  */
 243 static int decc_disable_to_vms_logname_translation = 1;
 244 static int decc_disable_posix_root = 1;
 245 int decc_efs_case_preserve = 0;
 246 static int decc_efs_charset = 0;
 247 static int decc_filename_unix_no_version = 0;
 248 static int decc_filename_unix_only = 0;
 249 int decc_filename_unix_report = 0;
 250 int decc_posix_compliant_pathnames = 0;
 251 int decc_readdir_dropdotnotype = 0;
 252 static int vms_process_case_tolerant = 1;
 253
 254 /* bug workarounds if needed */
 255 int decc_bug_readdir_efs1 = 0;
 256 int decc_bug_devnull = 1;
 257 int decc_bug_fgetname = 0;
 258 int decc_dir_barename = 0;
 259
 260 static int vms_debug_on_exception = 0;
 261
 262 /* Is this a UNIX file specification?
 263  *   No longer a simple check with EFS file specs
 264  *   For now, not a full check, but need to
 265  *   handle POSIX ^UP^ specifications
 266  *   Fixing to handle ^/ cases would require
 267  *   changes to many other conversion routines.
 268  */
 269
 270 static int is_unix_filespec(const char *path)
 271 {
 272 int ret_val;
 273 const char * pch1;
 274
 275     ret_val = 0;
 276     if (strncmp(path,"\"^UP^",5) != 0) {
 277         pch1 = strchr(path, '/');
 278         if (pch1 != NULL)
 279             ret_val = 1;
 280         else {
 281
 282             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 283             if (decc_filename_unix_report || decc_filename_unix_only) {
 284             if (strcmp(path,".") == 0)
 285                 ret_val = 1;
 286             }
 287         }
 288     }
 289     return ret_val;
 290 }
 291
 292 /* This handles the expansion of a '^' prefix to the proper character
 293  * in a UNIX file specification.
 294  *
 295  * The output count variable contains the number of characters added
 296  * to the output string.
 297  *
 298  * The return value is the number of characters read from the input
 299  * string
 300  */
 301 static int copy_expand_vms_filename_escape
 302   (char *outspec, const char *inspec, int *output_cnt)
 303 {
 304 int count;
 305 int scnt;
 306
 307     count = 0;
 308     *output_cnt = 0;
 309     if (*inspec == '^') {
 310         inspec++;
 311         switch (*inspec) {
 312         case '.':
 313             /* Non trailing dots should just be passed through */
 314             *outspec = *inspec;
 315             count++;
 316             (*output_cnt)++;
 317             break;
 318         case '_': /* space */
 319             *outspec = ' ';
 320             inspec++;
 321             count++;
 322             (*output_cnt)++;
 323             break;
 324         case 'U': /* Unicode */
 325             inspec++;
 326             count++;
 327             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 328             if (scnt == 4) {
 329                 scnt = sscanf(inspec, "%2x%2x", outspec, &outspec[1]);
 330                 if (scnt > 1) {
 331                     (*output_cnt) += 2;
 332                     count += 4;
 333                 }
 334             }
 335             else {
 336                 /* Error - do best we can to continue */
 337                 *outspec = 'U';
 338                 outspec++;
 339                 (*output_cnt++);
 340                 *outspec = *inspec;
 341                 count++;
 342                 (*output_cnt++);
 343             }
 344             break;
 345         default:
 346             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 347             if (scnt == 2) {
 348                 /* Hex encoded */
 349                 scnt = sscanf(inspec, "%2x", outspec);
 350                 if (scnt > 0) {
 351                     (*output_cnt++);
 352                     count += 2;
 353                 }
 354             }
 355             else {
 356                 *outspec = *inspec;
 357                 count++;
 358                 (*output_cnt++);
 359             }
 360         }
 361     }
 362     else {
 363         *outspec = *inspec;
 364         count++;
 365         (*output_cnt)++;
 366     }
 367     return count;
 368 }
 369
 370
 371 int SYS$FILESCAN
 372    (const struct dsc$descriptor_s * srcstr,
 373     struct filescan_itmlst_2 * valuelist,
 374     unsigned long * fldflags,
 375     struct dsc$descriptor_s *auxout,
 376     unsigned short * retlen);
 377
 378 /* vms_split_path - Verify that the input file specification is a
 379  * VMS format file specification, and provide pointers to the components of
 380  * it.  With EFS format filenames, this is virtually the only way to
 381  * parse a VMS path specification into components.
 382  *
 383  * If the sum of the components do not add up to the length of the
 384  * string, then the passed file specification is probably a UNIX style
 385  * path.
 386  */
 387 static int vms_split_path
 388    (const char * path,
 389     const char ** volume,
 390     int * vol_len,
 391     const char ** root,
 392     int * root_len,
 393     const char ** dir,
 394     int * dir_len,
 395     const char ** name,
 396     int * name_len,
 397     const char ** ext,
 398     int * ext_len,
 399     const char ** version,
 400     int * ver_len)
 401 {
 402 struct dsc$descriptor path_desc;
 403 int status;
 404 unsigned long flags;
 405 int ret_stat;
 406 struct filescan_itmlst_2 item_list[9];
 407 const int filespec = 0;
 408 const int nodespec = 1;
 409 const int devspec = 2;
 410 const int rootspec = 3;
 411 const int dirspec = 4;
 412 const int namespec = 5;
 413 const int typespec = 6;
 414 const int verspec = 7;
 415
 416     /* Assume the worst for an easy exit */
 417     ret_stat = -1;
 418     *volume = NULL;
 419     *vol_len = 0;
 420     *root = NULL;
 421     *root_len = 0;
 422     *dir = NULL;
 423     *dir_len;
 424     *name = NULL;
 425     *name_len = 0;
 426     *ext = NULL;
 427     *ext_len = 0;
 428     *version = NULL;
 429     *ver_len = 0;
 430
 431     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 432     path_desc.dsc$w_length = strlen(path);
 433     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 434     path_desc.dsc$b_class = DSC$K_CLASS_S;
 435
 436     /* Get the total length, if it is shorter than the string passed
 437      * then this was probably not a VMS formatted file specification
 438      */
 439     item_list[filespec].itmcode = FSCN$_FILESPEC;
 440     item_list[filespec].length = 0;
 441     item_list[filespec].component = NULL;
 442
 443     /* If the node is present, then it gets considered as part of the
 444      * volume name to hopefully make things simple.
 445      */
 446     item_list[nodespec].itmcode = FSCN$_NODE;
 447     item_list[nodespec].length = 0;
 448     item_list[nodespec].component = NULL;
 449
 450     item_list[devspec].itmcode = FSCN$_DEVICE;
 451     item_list[devspec].length = 0;
 452     item_list[devspec].component = NULL;
 453
 454     /* root is a special case,  adding it to either the directory or
 455      * the device components will probalby complicate things for the
 456      * callers of this routine, so leave it separate.
 457      */
 458     item_list[rootspec].itmcode = FSCN$_ROOT;
 459     item_list[rootspec].length = 0;
 460     item_list[rootspec].component = NULL;
 461
 462     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 463     item_list[dirspec].length = 0;
 464     item_list[dirspec].component = NULL;
 465
 466     item_list[namespec].itmcode = FSCN$_NAME;
 467     item_list[namespec].length = 0;
 468     item_list[namespec].component = NULL;
 469
 470     item_list[typespec].itmcode = FSCN$_TYPE;
 471     item_list[typespec].length = 0;
 472     item_list[typespec].component = NULL;
 473
 474     item_list[verspec].itmcode = FSCN$_VERSION;
 475     item_list[verspec].length = 0;
 476     item_list[verspec].component = NULL;
 477
 478     item_list[8].itmcode = 0;
 479     item_list[8].length = 0;
 480     item_list[8].component = NULL;
 481
 482     status = SYS$FILESCAN
 483        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 484         &flags, NULL, NULL);
 485     _ckvmssts(status); /* All failure status values indicate a coding error */
 486
 487     /* If we parsed it successfully these two lengths should be the same */
 488     if (path_desc.dsc$w_length != item_list[filespec].length)
 489         return ret_stat;
 490
 491     /* If we got here, then it is a VMS file specification */
 492     ret_stat = 0;
 493
 494     /* set the volume name */
 495     if (item_list[nodespec].length > 0) {
 496         *volume = item_list[nodespec].component;
 497         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 498     }
 499     else {
 500         *volume = item_list[devspec].component;
 501         *vol_len = item_list[devspec].length;
 502     }
 503
 504     *root = item_list[rootspec].component;
 505     *root_len = item_list[rootspec].length;
 506
 507     *dir = item_list[dirspec].component;
 508     *dir_len = item_list[dirspec].length;
 509
 510     /* Now fun with versions and EFS file specifications
 511      * The parser can not tell the difference when a "." is a version
 512      * delimiter or a part of the file specification.
 513      */
 514     if ((decc_efs_charset) &&
 515         (item_list[verspec].length > 0) &&
 516         (item_list[verspec].component[0] == '.')) {
 517         *name = item_list[namespec].component;
 518         *name_len = item_list[namespec].length + item_list[typespec].length;
 519         *ext = item_list[verspec].component;
 520         *ext_len = item_list[verspec].length;
 521         *version = NULL;
 522         *ver_len = 0;
 523     }
 524     else {
 525         *name = item_list[namespec].component;
 526         *name_len = item_list[namespec].length;
 527         *ext = item_list[typespec].component;
 528         *ext_len = item_list[typespec].length;
 529         *version = item_list[verspec].component;
 530         *ver_len = item_list[verspec].length;
 531     }
 532     return ret_stat;
 533 }
 534
 535
 536 /* my_maxidx
 537  * Routine to retrieve the maximum equivalence index for an input
 538  * logical name.  Some calls to this routine have no knowledge if
 539  * the variable is a logical or not.  So on error we return a max
 540  * index of zero.
 541  */
 542 /*{{{int my_maxidx(const char *lnm) */
 543 static int
 544 my_maxidx(const char *lnm)
 545 {
 546     int status;
 547     int midx;
 548     int attr = LNM$M_CASE_BLIND;
 549     struct dsc$descriptor lnmdsc;
 550     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 551                                 {0, 0, 0, 0}};
 552
 553     lnmdsc.dsc$w_length = strlen(lnm);
 554     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 555     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 556     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 557
 558     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 559     if ((status & 1) == 0)
 560        midx = 0;
 561
 562     return (midx);
 563 }
 564 /*}}}*/
 565
 566 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 567 int
 568 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 569   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 570 {
 571     const char *cp1;
 572     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 573     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 574     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 575     int midx;
 576     unsigned char acmode;
 577     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 578                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 579     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 580                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 581                                  {0, 0, 0, 0}};
 582     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 583 #if defined(PERL_IMPLICIT_CONTEXT)
 584     pTHX = NULL;
 585     if (PL_curinterp) {
 586       aTHX = PERL_GET_INTERP;
 587     } else {
 588       aTHX = NULL;
 589     }
 590 #endif
 591
 592     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 593       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 594     }
 595     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 596       *cp2 = _toupper(*cp1);
 597       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 598         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 599         return 0;
 600       }
 601     }
 602     lnmdsc.dsc$w_length = cp1 - lnm;
 603     lnmdsc.dsc$a_pointer = uplnm;
 604     uplnm[lnmdsc.dsc$w_length] = '\0';
 605     secure = flags & PERL__TRNENV_SECURE;
 606     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 607     if (!tabvec || !*tabvec) tabvec = env_tables;
 608
 609     for (curtab = 0; tabvec[curtab]; curtab++) {
 610       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 611         if (!ivenv && !secure) {
 612           char *eq, *end;
 613           int i;
 614           if (!environ) {
 615             ivenv = 1;
 616             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 617             continue;
 618           }
 619           retsts = SS$_NOLOGNAM;
 620           for (i = 0; environ[i]; i++) {
 621             if ((eq = strchr(environ[i],'=')) &&
 622                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 623                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 624               eq++;
 625               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 626               if (!eqvlen) continue;
 627               retsts = SS$_NORMAL;
 628               break;
 629             }
 630           }
 631           if (retsts != SS$_NOLOGNAM) break;
 632         }
 633       }
 634       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 635                !str$case_blind_compare(&tmpdsc,&clisym)) {
 636         if (!ivsym && !secure) {
 637           unsigned short int deflen = LNM$C_NAMLENGTH;
 638           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 639           /* dynamic dsc to accomodate possible long value */
 640           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 641           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 642           if (retsts & 1) {
 643             if (eqvlen > MAX_DCL_SYMBOL) {
 644               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 645               eqvlen = MAX_DCL_SYMBOL;
 646               /* Special hack--we might be called before the interpreter's */
 647               /* fully initialized, in which case either thr or PL_curcop */
 648               /* might be bogus. We have to check, since ckWARN needs them */
 649               /* both to be valid if running threaded */
 650                 if (ckWARN(WARN_MISC)) {
 651                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 652                 }
 653             }
 654             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 655           }
 656           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 657           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 658           if (retsts == LIB$_NOSUCHSYM) continue;
 659           break;
 660         }
 661       }
 662       else if (!ivlnm) {
 663         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 664           midx = my_maxidx(lnm);
 665           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 666             lnmlst[1].bufadr = cp2;
 667             eqvlen = 0;
 668             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 669             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 670             if (retsts == SS$_NOLOGNAM) break;
 671             /* PPFs have a prefix */
 672             if (
 673 #if INTSIZE == 4
 674                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 675 #endif
 676                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 677                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 678                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 679                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 680                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 681               memmove(eqv,eqv+4,eqvlen-4);
 682               eqvlen -= 4;
 683             }
 684             cp2 += eqvlen;
 685             *cp2 = '\0';
 686           }
 687           if ((retsts == SS$_IVLOGNAM) ||
 688               (retsts == SS$_NOLOGNAM)) { continue; }
 689         }
 690         else {
 691           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 692           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 693           if (retsts == SS$_NOLOGNAM) continue;
 694           eqv[eqvlen] = '\0';
 695         }
 696         eqvlen = strlen(eqv);
 697         break;
 698       }
 699     }
 700     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 701     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 702              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 703              retsts == SS$_NOLOGNAM) {
 704       set_errno(EINVAL);  set_vaxc_errno(retsts);
 705     }
 706     else _ckvmssts(retsts);
 707     return 0;
 708 }  /* end of vmstrnenv */
 709 /*}}}*/
 710
 711 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 712 /* Define as a function so we can access statics. */
 713 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 714 {
 715   return vmstrnenv(lnm,eqv,idx,fildev,
 716 #ifdef SECURE_INTERNAL_GETENV
 717                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 718 #else
 719                    0
 720 #endif
 721                                                                               );
 722 }
 723 /*}}}*/
 724
 725 /* my_getenv
 726  * Note: Uses Perl temp to store result so char * can be returned to
 727  * caller; this pointer will be invalidated at next Perl statement
 728  * transition.
 729  * We define this as a function rather than a macro in terms of my_getenv_len()
 730  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 731  * allocate SVs).
 732  */
 733 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 734 char *
 735 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 736 {
 737     const char *cp1;
 738     static char *__my_getenv_eqv = NULL;
 739     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 740     unsigned long int idx = 0;
 741     int trnsuccess, success, secure, saverr, savvmserr;
 742     int midx, flags;
 743     SV *tmpsv;
 744
 745     midx = my_maxidx(lnm) + 1;
 746
 747     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 748       /* Set up a temporary buffer for the return value; Perl will
 749        * clean it up at the next statement transition */
 750       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 751       if (!tmpsv) return NULL;
 752       eqv = SvPVX(tmpsv);
 753     }
 754     else {
 755       /* Assume no interpreter ==> single thread */
 756       if (__my_getenv_eqv != NULL) {
 757         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 758       }
 759       else {
 760         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 761       }
 762       eqv = __my_getenv_eqv;
 763     }
 764
 765     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 766     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 767       int len;
 768       getcwd(eqv,LNM$C_NAMLENGTH);
 769
 770       len = strlen(eqv);
 771
 772       /* Get rid of "000000/ in rooted filespecs */
 773       if (len > 7) {
 774         char * zeros;
 775         zeros = strstr(eqv, "/000000/");
 776         if (zeros != NULL) {
 777           int mlen;
 778           mlen = len - (zeros - eqv) - 7;
 779           memmove(zeros, &zeros[7], mlen);
 780           len = len - 7;
 781           eqv[len] = '\0';
 782         }
 783       }
 784       return eqv;
 785     }
 786     else {
 787       /* Impose security constraints only if tainting */
 788       if (sys) {
 789         /* Impose security constraints only if tainting */
 790         secure = PL_curinterp ? PL_tainting : will_taint;
 791         saverr = errno;  savvmserr = vaxc$errno;
 792       }
 793       else {
 794         secure = 0;
 795       }
 796
 797       flags =
 798 #ifdef SECURE_INTERNAL_GETENV
 799               secure ? PERL__TRNENV_SECURE : 0
 800 #else
 801               0
 802 #endif
 803       ;
 804
 805       /* For the getenv interface we combine all the equivalence names
 806        * of a search list logical into one value to acquire a maximum
 807        * value length of 255*128 (assuming %ENV is using logicals).
 808        */
 809       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 810
 811       /* If the name contains a semicolon-delimited index, parse it
 812        * off and make sure we only retrieve the equivalence name for
 813        * that index.  */
 814       if ((cp2 = strchr(lnm,';')) != NULL) {
 815         strcpy(uplnm,lnm);
 816         uplnm[cp2-lnm] = '\0';
 817         idx = strtoul(cp2+1,NULL,0);
 818         lnm = uplnm;
 819         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 820       }
 821
 822       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
 823
 824       /* Discard NOLOGNAM on internal calls since we're often looking
 825        * for an optional name, and this "error" often shows up as the
 826        * (bogus) exit status for a die() call later on.  */
 827       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 828       return success ? eqv : Nullch;
 829     }
 830
 831 }  /* end of my_getenv() */
 832 /*}}}*/
 833
 834
 835 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 836 char *
 837 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 838 {
 839     const char *cp1;
 840     char *buf, *cp2;
 841     unsigned long idx = 0;
 842     int midx, flags;
 843     static char *__my_getenv_len_eqv = NULL;
 844     int secure, saverr, savvmserr;
 845     SV *tmpsv;
 846
 847     midx = my_maxidx(lnm) + 1;
 848
 849     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 850       /* Set up a temporary buffer for the return value; Perl will
 851        * clean it up at the next statement transition */
 852       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 853       if (!tmpsv) return NULL;
 854       buf = SvPVX(tmpsv);
 855     }
 856     else {
 857       /* Assume no interpreter ==> single thread */
 858       if (__my_getenv_len_eqv != NULL) {
 859         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 860       }
 861       else {
 862         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 863       }
 864       buf = __my_getenv_len_eqv;
 865     }
 866
 867     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 868     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 869     char * zeros;
 870
 871       getcwd(buf,LNM$C_NAMLENGTH);
 872       *len = strlen(buf);
 873
 874       /* Get rid of "000000/ in rooted filespecs */
 875       if (*len > 7) {
 876       zeros = strstr(buf, "/000000/");
 877       if (zeros != NULL) {
 878         int mlen;
 879         mlen = *len - (zeros - buf) - 7;
 880         memmove(zeros, &zeros[7], mlen);
 881         *len = *len - 7;
 882         buf[*len] = '\0';
 883         }
 884       }
 885       return buf;
 886     }
 887     else {
 888       if (sys) {
 889         /* Impose security constraints only if tainting */
 890         secure = PL_curinterp ? PL_tainting : will_taint;
 891         saverr = errno;  savvmserr = vaxc$errno;
 892       }
 893       else {
 894         secure = 0;
 895       }
 896
 897       flags =
 898 #ifdef SECURE_INTERNAL_GETENV
 899               secure ? PERL__TRNENV_SECURE : 0
 900 #else
 901               0
 902 #endif
 903       ;
 904
 905       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 906
 907       if ((cp2 = strchr(lnm,';')) != NULL) {
 908         strcpy(buf,lnm);
 909         buf[cp2-lnm] = '\0';
 910         idx = strtoul(cp2+1,NULL,0);
 911         lnm = buf;
 912         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 913       }
 914
 915       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
 916
 917       /* Get rid of "000000/ in rooted filespecs */
 918       if (*len > 7) {
 919       char * zeros;
 920         zeros = strstr(buf, "/000000/");
 921         if (zeros != NULL) {
 922           int mlen;
 923           mlen = *len - (zeros - buf) - 7;
 924           memmove(zeros, &zeros[7], mlen);
 925           *len = *len - 7;
 926           buf[*len] = '\0';
 927         }
 928       }
 929
 930       /* Discard NOLOGNAM on internal calls since we're often looking
 931        * for an optional name, and this "error" often shows up as the
 932        * (bogus) exit status for a die() call later on.  */
 933       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 934       return *len ? buf : Nullch;
 935     }
 936
 937 }  /* end of my_getenv_len() */
 938 /*}}}*/
 939
 940 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 941
 942 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 943
 944 /*{{{ void prime_env_iter() */
 945 void
 946 prime_env_iter(void)
 947 /* Fill the %ENV associative array with all logical names we can
 948  * find, in preparation for iterating over it.
 949  */
 950 {
 951   static int primed = 0;
 952   HV *seenhv = NULL, *envhv;
 953   SV *sv = NULL;
 954   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 955   unsigned short int chan;
 956 #ifndef CLI$M_TRUSTED
 957 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 958 #endif
 959   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 960   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 961   long int i;
 962   bool have_sym = FALSE, have_lnm = FALSE;
 963   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 964   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 965   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 966   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 967   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 968 #if defined(PERL_IMPLICIT_CONTEXT)
 969   pTHX;
 970 #endif
 971 #if defined(USE_ITHREADS)
 972   static perl_mutex primenv_mutex;
 973   MUTEX_INIT(&primenv_mutex);
 974 #endif
 975
 976 #if defined(PERL_IMPLICIT_CONTEXT)
 977     /* We jump through these hoops because we can be called at */
 978     /* platform-specific initialization time, which is before anything is */
 979     /* set up--we can't even do a plain dTHX since that relies on the */
 980     /* interpreter structure to be initialized */
 981     if (PL_curinterp) {
 982       aTHX = PERL_GET_INTERP;
 983     } else {
 984       aTHX = NULL;
 985     }
 986 #endif
 987
 988   if (primed || !PL_envgv) return;
 989   MUTEX_LOCK(&primenv_mutex);
 990   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
 991   envhv = GvHVn(PL_envgv);
 992   /* Perform a dummy fetch as an lval to insure that the hash table is
 993    * set up.  Otherwise, the hv_store() will turn into a nullop. */
 994   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
 995
 996   for (i = 0; env_tables[i]; i++) {
 997      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 998          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
 999      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1000   }
1001   if (have_sym || have_lnm) {
1002     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1003     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1004     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1005     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1006   }
1007
1008   for (i--; i >= 0; i--) {
1009     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1010       char *start;
1011       int j;
1012       for (j = 0; environ[j]; j++) {
1013         if (!(start = strchr(environ[j],'='))) {
1014           if (ckWARN(WARN_INTERNAL))
1015             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1016         }
1017         else {
1018           start++;
1019           sv = newSVpv(start,0);
1020           SvTAINTED_on(sv);
1021           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1022         }
1023       }
1024       continue;
1025     }
1026     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1027              !str$case_blind_compare(&tmpdsc,&clisym)) {
1028       strcpy(cmd,"Show Symbol/Global *");
1029       cmddsc.dsc$w_length = 20;
1030       if (env_tables[i]->dsc$w_length == 12 &&
1031           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1032           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1033       flags = defflags | CLI$M_NOLOGNAM;
1034     }
1035     else {
1036       strcpy(cmd,"Show Logical *");
1037       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1038         strcat(cmd," /Table=");
1039         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1040         cmddsc.dsc$w_length = strlen(cmd);
1041       }
1042       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1043       flags = defflags | CLI$M_NOCLISYM;
1044     }
1045
1046     /* Create a new subprocess to execute each command, to exclude the
1047      * remote possibility that someone could subvert a mbx or file used
1048      * to write multiple commands to a single subprocess.
1049      */
1050     do {
1051       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1052                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1053       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1054       defflags &= ~CLI$M_TRUSTED;
1055     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1056     _ckvmssts(retsts);
1057     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1058     if (seenhv) SvREFCNT_dec(seenhv);
1059     seenhv = newHV();
1060     while (1) {
1061       char *cp1, *cp2, *key;
1062       unsigned long int sts, iosb[2], retlen, keylen;
1063       register U32 hash;
1064
1065       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1066       if (sts & 1) sts = iosb[0] & 0xffff;
1067       if (sts == SS$_ENDOFFILE) {
1068         int wakect = 0;
1069         while (substs == 0) { sys$hiber(); wakect++;}
1070         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1071         _ckvmssts(substs);
1072         break;
1073       }
1074       _ckvmssts(sts);
1075       retlen = iosb[0] >> 16;
1076       if (!retlen) continue;  /* blank line */
1077       buf[retlen] = '\0';
1078       if (iosb[1] != subpid) {
1079         if (iosb[1]) {
1080           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1081         }
1082         continue;
1083       }
1084       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1085         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1086
1087       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1088       if (*cp1 == '(' || /* Logical name table name */
1089           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1090       if (*cp1 == '"') cp1++;
1091       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1092       key = cp1;  keylen = cp2 - cp1;
1093       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1094       while (*cp2 && *cp2 != '=') cp2++;
1095       while (*cp2 && *cp2 == '=') cp2++;
1096       while (*cp2 && *cp2 == ' ') cp2++;
1097       if (*cp2 == '"') {  /* String translation; may embed "" */
1098         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1099         cp2++;  cp1--; /* Skip "" surrounding translation */
1100       }
1101       else {  /* Numeric translation */
1102         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1103         cp1--;  /* stop on last non-space char */
1104       }
1105       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1106         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1107         continue;
1108       }
1109       PERL_HASH(hash,key,keylen);
1110
1111       if (cp1 == cp2 && *cp2 == '.') {
1112         /* A single dot usually means an unprintable character, such as a null
1113          * to indicate a zero-length value.  Get the actual value to make sure.
1114          */
1115         char lnm[LNM$C_NAMLENGTH+1];
1116         char eqv[MAX_DCL_SYMBOL+1];
1117         strncpy(lnm, key, keylen);
1118         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1119         sv = newSVpvn(eqv, strlen(eqv));
1120       }
1121       else {
1122         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1123       }
1124
1125       SvTAINTED_on(sv);
1126       hv_store(envhv,key,keylen,sv,hash);
1127       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1128     }
1129     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1130       /* get the PPFs for this process, not the subprocess */
1131       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1132       char eqv[LNM$C_NAMLENGTH+1];
1133       int trnlen, i;
1134       for (i = 0; ppfs[i]; i++) {
1135         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1136         sv = newSVpv(eqv,trnlen);
1137         SvTAINTED_on(sv);
1138         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1139       }
1140     }
1141   }
1142   primed = 1;
1143   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1144   if (buf) Safefree(buf);
1145   if (seenhv) SvREFCNT_dec(seenhv);
1146   MUTEX_UNLOCK(&primenv_mutex);
1147   return;
1148
1149 }  /* end of prime_env_iter */
1150 /*}}}*/
1151
1152
1153 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1154 /* Define or delete an element in the same "environment" as
1155  * vmstrnenv().  If an element is to be deleted, it's removed from
1156  * the first place it's found.  If it's to be set, it's set in the
1157  * place designated by the first element of the table vector.
1158  * Like setenv() returns 0 for success, non-zero on error.
1159  */
1160 int
1161 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1162 {
1163     const char *cp1;
1164     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1165     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1166     int nseg = 0, j;
1167     unsigned long int retsts, usermode = PSL$C_USER;
1168     struct itmlst_3 *ile, *ilist;
1169     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1170                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1171                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1172     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1173     $DESCRIPTOR(local,"_LOCAL");
1174
1175     if (!lnm) {
1176         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1177         return SS$_IVLOGNAM;
1178     }
1179
1180     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1181       *cp2 = _toupper(*cp1);
1182       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1183         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1184         return SS$_IVLOGNAM;
1185       }
1186     }
1187     lnmdsc.dsc$w_length = cp1 - lnm;
1188     if (!tabvec || !*tabvec) tabvec = env_tables;
1189
1190     if (!eqv) {  /* we're deleting n element */
1191       for (curtab = 0; tabvec[curtab]; curtab++) {
1192         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1193         int i;
1194           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1195             if ((cp1 = strchr(environ[i],'=')) &&
1196                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1197                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1198 #ifdef HAS_SETENV
1199               return setenv(lnm,"",1) ? vaxc$errno : 0;
1200             }
1201           }
1202           ivenv = 1; retsts = SS$_NOLOGNAM;
1203 #else
1204               if (ckWARN(WARN_INTERNAL))
1205                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1206               ivenv = 1; retsts = SS$_NOSUCHPGM;
1207               break;
1208             }
1209           }
1210 #endif
1211         }
1212         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1213                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1214           unsigned int symtype;
1215           if (tabvec[curtab]->dsc$w_length == 12 &&
1216               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1217               !str$case_blind_compare(&tmpdsc,&local))
1218             symtype = LIB$K_CLI_LOCAL_SYM;
1219           else symtype = LIB$K_CLI_GLOBAL_SYM;
1220           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1221           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1222           if (retsts == LIB$_NOSUCHSYM) continue;
1223           break;
1224         }
1225         else if (!ivlnm) {
1226           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1227           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1228           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1229           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1230           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1231         }
1232       }
1233     }
1234     else {  /* we're defining a value */
1235       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1236 #ifdef HAS_SETENV
1237         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1238 #else
1239         if (ckWARN(WARN_INTERNAL))
1240           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1241         retsts = SS$_NOSUCHPGM;
1242 #endif
1243       }
1244       else {
1245         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1246         eqvdsc.dsc$w_length  = strlen(eqv);
1247         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1248             !str$case_blind_compare(&tmpdsc,&clisym)) {
1249           unsigned int symtype;
1250           if (tabvec[0]->dsc$w_length == 12 &&
1251               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1252                !str$case_blind_compare(&tmpdsc,&local))
1253             symtype = LIB$K_CLI_LOCAL_SYM;
1254           else symtype = LIB$K_CLI_GLOBAL_SYM;
1255           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1256         }
1257         else {
1258           if (!*eqv) eqvdsc.dsc$w_length = 1;
1259           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1260
1261             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1262             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1263               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1264                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1265               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1266               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1267             }
1268
1269             Newx(ilist,nseg+1,struct itmlst_3);
1270             ile = ilist;
1271             if (!ile) {
1272               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1273               return SS$_INSFMEM;
1274             }
1275             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1276
1277             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1278               ile->itmcode = LNM$_STRING;
1279               ile->bufadr = c;
1280               if ((j+1) == nseg) {
1281                 ile->buflen = strlen(c);
1282                 /* in case we are truncating one that's too long */
1283                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1284               }
1285               else {
1286                 ile->buflen = LNM$C_NAMLENGTH;
1287               }
1288             }
1289
1290             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1291             Safefree (ilist);
1292           }
1293           else {
1294             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1295           }
1296         }
1297       }
1298     }
1299     if (!(retsts & 1)) {
1300       switch (retsts) {
1301         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1302         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1303           set_errno(EVMSERR); break;
1304         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1305         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1306           set_errno(EINVAL); break;
1307         case SS$_NOPRIV:
1308           set_errno(EACCES);
1309         default:
1310           _ckvmssts(retsts);
1311           set_errno(EVMSERR);
1312        }
1313        set_vaxc_errno(retsts);
1314        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1315     }
1316     else {
1317       /* We reset error values on success because Perl does an hv_fetch()
1318        * before each hv_store(), and if the thing we're setting didn't
1319        * previously exist, we've got a leftover error message.  (Of course,
1320        * this fails in the face of
1321        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1322        * in that the error reported in $! isn't spurious,
1323        * but it's right more often than not.)
1324        */
1325       set_errno(0); set_vaxc_errno(retsts);
1326       return 0;
1327     }
1328
1329 }  /* end of vmssetenv() */
1330 /*}}}*/
1331
1332 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1333 /* This has to be a function since there's a prototype for it in proto.h */
1334 void
1335 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1336 {
1337     if (lnm && *lnm) {
1338       int len = strlen(lnm);
1339       if  (len == 7) {
1340         char uplnm[8];
1341         int i;
1342         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1343         if (!strcmp(uplnm,"DEFAULT")) {
1344           if (eqv && *eqv) my_chdir(eqv);
1345           return;
1346         }
1347     }
1348 #ifndef RTL_USES_UTC
1349     if (len == 6 || len == 2) {
1350       char uplnm[7];
1351       int i;
1352       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1353       uplnm[len] = '\0';
1354       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1355       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1356     }
1357 #endif
1358   }
1359   (void) vmssetenv(lnm,eqv,NULL);
1360 }
1361 /*}}}*/
1362
1363 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1364 /*  vmssetuserlnm
1365  *  sets a user-mode logical in the process logical name table
1366  *  used for redirection of sys$error
1367  */
1368 void
1369 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1370 {
1371     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1372     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1373     unsigned long int iss, attr = LNM$M_CONFINE;
1374     unsigned char acmode = PSL$C_USER;
1375     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1376                                  {0, 0, 0, 0}};
1377     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1378     d_name.dsc$w_length = strlen(name);
1379
1380     lnmlst[0].buflen = strlen(eqv);
1381     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1382
1383     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1384     if (!(iss&1)) lib$signal(iss);
1385 }
1386 /*}}}*/
1387
1388
1389 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1390 /* my_crypt - VMS password hashing
1391  * my_crypt() provides an interface compatible with the Unix crypt()
1392  * C library function, and uses sys$hash_password() to perform VMS
1393  * password hashing.  The quadword hashed password value is returned
1394  * as a NUL-terminated 8 character string.  my_crypt() does not change
1395  * the case of its string arguments; in order to match the behavior
1396  * of LOGINOUT et al., alphabetic characters in both arguments must
1397  *  be upcased by the caller.
1398  *
1399  * - fix me to call ACM services when available
1400  */
1401 char *
1402 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1403 {
1404 #   ifndef UAI$C_PREFERRED_ALGORITHM
1405 #     define UAI$C_PREFERRED_ALGORITHM 127
1406 #   endif
1407     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1408     unsigned short int salt = 0;
1409     unsigned long int sts;
1410     struct const_dsc {
1411         unsigned short int dsc$w_length;
1412         unsigned char      dsc$b_type;
1413         unsigned char      dsc$b_class;
1414         const char *       dsc$a_pointer;
1415     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1416        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1417     struct itmlst_3 uailst[3] = {
1418         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1419         { sizeof salt, UAI$_SALT,    &salt, 0},
1420         { 0,           0,            NULL,  NULL}};
1421     static char hash[9];
1422
1423     usrdsc.dsc$w_length = strlen(usrname);
1424     usrdsc.dsc$a_pointer = usrname;
1425     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1426       switch (sts) {
1427         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1428           set_errno(EACCES);
1429           break;
1430         case RMS$_RNF:
1431           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1432           break;
1433         default:
1434           set_errno(EVMSERR);
1435       }
1436       set_vaxc_errno(sts);
1437       if (sts != RMS$_RNF) return NULL;
1438     }
1439
1440     txtdsc.dsc$w_length = strlen(textpasswd);
1441     txtdsc.dsc$a_pointer = textpasswd;
1442     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1443       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1444     }
1445
1446     return (char *) hash;
1447
1448 }  /* end of my_crypt() */
1449 /*}}}*/
1450
1451
1452 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1453 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1454 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1455
1456 /* fixup barenames that are directories for internal use.
1457  * There have been problems with the consistent handling of UNIX
1458  * style directory names when routines are presented with a name that
1459  * has no directory delimitors at all.  So this routine will eventually
1460  * fix the issue.
1461  */
1462 static char * fixup_bare_dirnames(const char * name)
1463 {
1464   if (decc_disable_to_vms_logname_translation) {
1465 /* fix me */
1466   }
1467   return NULL;
1468 }
1469
1470 /* mp_do_kill_file
1471  * A little hack to get around a bug in some implemenation of remove()
1472  * that do not know how to delete a directory
1473  *
1474  * Delete any file to which user has control access, regardless of whether
1475  * delete access is explicitly allowed.
1476  * Limitations: User must have write access to parent directory.
1477  *              Does not block signals or ASTs; if interrupted in midstream
1478  *              may leave file with an altered ACL.
1479  * HANDLE WITH CARE!
1480  */
1481 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1482 static int
1483 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1484 {
1485     char *vmsname, *rspec;
1486     char *remove_name;
1487     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1488     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1489     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1490     struct myacedef {
1491       unsigned char myace$b_length;
1492       unsigned char myace$b_type;
1493       unsigned short int myace$w_flags;
1494       unsigned long int myace$l_access;
1495       unsigned long int myace$l_ident;
1496     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1497                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1498       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1499      struct itmlst_3
1500        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1501                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1502        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1503        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1504        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1505        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1506
1507     /* Expand the input spec using RMS, since the CRTL remove() and
1508      * system services won't do this by themselves, so we may miss
1509      * a file "hiding" behind a logical name or search list. */
1510     Newx(vmsname, NAM$C_MAXRSS+1, char);
1511     if (do_tovmsspec(name,vmsname,0) == NULL) {
1512       Safefree(vmsname);
1513       return -1;
1514     }
1515
1516     if (decc_posix_compliant_pathnames) {
1517       /* In POSIX mode, we prefer to remove the UNIX name */
1518       rspec = vmsname;
1519       remove_name = (char *)name;
1520     }
1521     else {
1522       Newx(rspec, NAM$C_MAXRSS+1, char);
1523       if (do_rmsexpand(vmsname, rspec, 1, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1524         Safefree(rspec);
1525         Safefree(vmsname);
1526         return -1;
1527       }
1528       Safefree(vmsname);
1529       remove_name = rspec;
1530     }
1531
1532 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1533     if (dirflag != 0) {
1534         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1535           Newx(remove_name, NAM$C_MAXRSS+1, char);
1536           do_pathify_dirspec(name, remove_name, 0);
1537           if (!rmdir(remove_name)) {
1538
1539             Safefree(remove_name);
1540             Safefree(rspec);
1541             return 0;   /* Can we just get rid of it? */
1542           }
1543         }
1544         else {
1545           if (!rmdir(remove_name)) {
1546             Safefree(rspec);
1547             return 0;   /* Can we just get rid of it? */
1548           }
1549         }
1550     }
1551     else
1552 #endif
1553       if (!remove(remove_name)) {
1554         Safefree(rspec);
1555         return 0;   /* Can we just get rid of it? */
1556       }
1557
1558     /* If not, can changing protections help? */
1559     if (vaxc$errno != RMS$_PRV) {
1560       Safefree(rspec);
1561       return -1;
1562     }
1563
1564     /* No, so we get our own UIC to use as a rights identifier,
1565      * and the insert an ACE at the head of the ACL which allows us
1566      * to delete the file.
1567      */
1568     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1569     fildsc.dsc$w_length = strlen(rspec);
1570     fildsc.dsc$a_pointer = rspec;
1571     cxt = 0;
1572     newace.myace$l_ident = oldace.myace$l_ident;
1573     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1574       switch (aclsts) {
1575         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1576           set_errno(ENOENT); break;
1577         case RMS$_DIR:
1578           set_errno(ENOTDIR); break;
1579         case RMS$_DEV:
1580           set_errno(ENODEV); break;
1581         case RMS$_SYN: case SS$_INVFILFOROP:
1582           set_errno(EINVAL); break;
1583         case RMS$_PRV:
1584           set_errno(EACCES); break;
1585         default:
1586           _ckvmssts(aclsts);
1587       }
1588       set_vaxc_errno(aclsts);
1589       Safefree(rspec);
1590       return -1;
1591     }
1592     /* Grab any existing ACEs with this identifier in case we fail */
1593     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1594     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1595                     || fndsts == SS$_NOMOREACE ) {
1596       /* Add the new ACE . . . */
1597       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1598         goto yourroom;
1599
1600 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1601       if (dirflag != 0)
1602         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1603           Newx(remove_name, NAM$C_MAXRSS+1, char);
1604           do_pathify_dirspec(name, remove_name, 0);
1605           rmsts = rmdir(remove_name);
1606           Safefree(remove_name);
1607         }
1608         else {
1609         rmsts = rmdir(remove_name);
1610         }
1611       else
1612 #endif
1613         rmsts = remove(remove_name);
1614       if (rmsts) {
1615         /* We blew it - dir with files in it, no write priv for
1616          * parent directory, etc.  Put things back the way they were. */
1617         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1618           goto yourroom;
1619         if (fndsts & 1) {
1620           addlst[0].bufadr = &oldace;
1621           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1622             goto yourroom;
1623         }
1624       }
1625     }
1626
1627     yourroom:
1628     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1629     /* We just deleted it, so of course it's not there.  Some versions of
1630      * VMS seem to return success on the unlock operation anyhow (after all
1631      * the unlock is successful), but others don't.
1632      */
1633     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1634     if (aclsts & 1) aclsts = fndsts;
1635     if (!(aclsts & 1)) {
1636       set_errno(EVMSERR);
1637       set_vaxc_errno(aclsts);
1638       Safefree(rspec);
1639       return -1;
1640     }
1641
1642     Safefree(rspec);
1643     return rmsts;
1644
1645 }  /* end of kill_file() */
1646 /*}}}*/
1647
1648
1649 /*{{{int do_rmdir(char *name)*/
1650 int
1651 Perl_do_rmdir(pTHX_ const char *name)
1652 {
1653     char dirfile[NAM$C_MAXRSS+1];
1654     int retval;
1655     Stat_t st;
1656
1657     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1658     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1659     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1660     return retval;
1661
1662 }  /* end of do_rmdir */
1663 /*}}}*/
1664
1665 /* kill_file
1666  * Delete any file to which user has control access, regardless of whether
1667  * delete access is explicitly allowed.
1668  * Limitations: User must have write access to parent directory.
1669  *              Does not block signals or ASTs; if interrupted in midstream
1670  *              may leave file with an altered ACL.
1671  * HANDLE WITH CARE!
1672  */
1673 /*{{{int kill_file(char *name)*/
1674 int
1675 Perl_kill_file(pTHX_ const char *name)
1676 {
1677     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1678     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1679     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1680     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1681     struct myacedef {
1682       unsigned char myace$b_length;
1683       unsigned char myace$b_type;
1684       unsigned short int myace$w_flags;
1685       unsigned long int myace$l_access;
1686       unsigned long int myace$l_ident;
1687     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1688                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1689       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1690      struct itmlst_3
1691        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1692                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1693        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1694        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1695        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1696        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1697
1698     /* Expand the input spec using RMS, since the CRTL remove() and
1699      * system services won't do this by themselves, so we may miss
1700      * a file "hiding" behind a logical name or search list. */
1701     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1702     if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1703     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1704     /* If not, can changing protections help? */
1705     if (vaxc$errno != RMS$_PRV) return -1;
1706
1707     /* No, so we get our own UIC to use as a rights identifier,
1708      * and the insert an ACE at the head of the ACL which allows us
1709      * to delete the file.
1710      */
1711     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1712     fildsc.dsc$w_length = strlen(rspec);
1713     fildsc.dsc$a_pointer = rspec;
1714     cxt = 0;
1715     newace.myace$l_ident = oldace.myace$l_ident;
1716     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1717       switch (aclsts) {
1718         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1719           set_errno(ENOENT); break;
1720         case RMS$_DIR:
1721           set_errno(ENOTDIR); break;
1722         case RMS$_DEV:
1723           set_errno(ENODEV); break;
1724         case RMS$_SYN: case SS$_INVFILFOROP:
1725           set_errno(EINVAL); break;
1726         case RMS$_PRV:
1727           set_errno(EACCES); break;
1728         default:
1729           _ckvmssts(aclsts);
1730       }
1731       set_vaxc_errno(aclsts);
1732       return -1;
1733     }
1734     /* Grab any existing ACEs with this identifier in case we fail */
1735     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1736     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1737                     || fndsts == SS$_NOMOREACE ) {
1738       /* Add the new ACE . . . */
1739       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1740         goto yourroom;
1741       if ((rmsts = remove(name))) {
1742         /* We blew it - dir with files in it, no write priv for
1743          * parent directory, etc.  Put things back the way they were. */
1744         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1745           goto yourroom;
1746         if (fndsts & 1) {
1747           addlst[0].bufadr = &oldace;
1748           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1749             goto yourroom;
1750         }
1751       }
1752     }
1753
1754     yourroom:
1755     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1756     /* We just deleted it, so of course it's not there.  Some versions of
1757      * VMS seem to return success on the unlock operation anyhow (after all
1758      * the unlock is successful), but others don't.
1759      */
1760     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1761     if (aclsts & 1) aclsts = fndsts;
1762     if (!(aclsts & 1)) {
1763       set_errno(EVMSERR);
1764       set_vaxc_errno(aclsts);
1765       return -1;
1766     }
1767
1768     return rmsts;
1769
1770 }  /* end of kill_file() */
1771 /*}}}*/
1772
1773
1774 /*{{{int my_mkdir(char *,Mode_t)*/
1775 int
1776 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1777 {
1778   STRLEN dirlen = strlen(dir);
1779
1780   /* zero length string sometimes gives ACCVIO */
1781   if (dirlen == 0) return -1;
1782
1783   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1784    * null file name/type.  However, it's commonplace under Unix,
1785    * so we'll allow it for a gain in portability.
1786    */
1787   if (dir[dirlen-1] == '/') {
1788     char *newdir = savepvn(dir,dirlen-1);
1789     int ret = mkdir(newdir,mode);
1790     Safefree(newdir);
1791     return ret;
1792   }
1793   else return mkdir(dir,mode);
1794 }  /* end of my_mkdir */
1795 /*}}}*/
1796
1797 /*{{{int my_chdir(char *)*/
1798 int
1799 Perl_my_chdir(pTHX_ const char *dir)
1800 {
1801   STRLEN dirlen = strlen(dir);
1802
1803   /* zero length string sometimes gives ACCVIO */
1804   if (dirlen == 0) return -1;
1805   const char *dir1;
1806
1807   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1808    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
1809    * so that existing scripts do not need to be changed.
1810    */
1811   dir1 = dir;
1812   while ((dirlen > 0) && (*dir1 == ' ')) {
1813     dir1++;
1814     dirlen--;
1815   }
1816
1817   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1818    * that implies
1819    * null file name/type.  However, it's commonplace under Unix,
1820    * so we'll allow it for a gain in portability.
1821    *
1822    * - Preview- '/' will be valid soon on VMS
1823    */
1824   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1825     char *newdir = savepvn(dir,dirlen-1);
1826     int ret = chdir(newdir);
1827     Safefree(newdir);
1828     return ret;
1829   }
1830   else return chdir(dir);
1831 }  /* end of my_chdir */
1832 /*}}}*/
1833
1834
1835 /*{{{FILE *my_tmpfile()*/
1836 FILE *
1837 my_tmpfile(void)
1838 {
1839   FILE *fp;
1840   char *cp;
1841
1842   if ((fp = tmpfile())) return fp;
1843
1844   Newx(cp,L_tmpnam+24,char);
1845   if (decc_filename_unix_only == 0)
1846     strcpy(cp,"Sys$Scratch:");
1847   else
1848     strcpy(cp,"/tmp/");
1849   tmpnam(cp+strlen(cp));
1850   strcat(cp,".Perltmp");
1851   fp = fopen(cp,"w+","fop=dlt");
1852   Safefree(cp);
1853   return fp;
1854 }
1855 /*}}}*/
1856
1857
1858 #ifndef HOMEGROWN_POSIX_SIGNALS
1859 /*
1860  * The C RTL's sigaction fails to check for invalid signal numbers so we
1861  * help it out a bit.  The docs are correct, but the actual routine doesn't
1862  * do what the docs say it will.
1863  */
1864 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1865 int
1866 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1867                    struct sigaction* oact)
1868 {
1869   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1870         SETERRNO(EINVAL, SS$_INVARG);
1871         return -1;
1872   }
1873   return sigaction(sig, act, oact);
1874 }
1875 /*}}}*/
1876 #endif
1877
1878 #ifdef KILL_BY_SIGPRC
1879 #include <errnodef.h>
1880
1881 /* We implement our own kill() using the undocumented system service
1882    sys$sigprc for one of two reasons:
1883
1884    1.) If the kill() in an older CRTL uses sys$forcex, causing the
1885    target process to do a sys$exit, which usually can't be handled
1886    gracefully...certainly not by Perl and the %SIG{} mechanism.
1887
1888    2.) If the kill() in the CRTL can't be called from a signal
1889    handler without disappearing into the ether, i.e., the signal
1890    it purportedly sends is never trapped. Still true as of VMS 7.3.
1891
1892    sys$sigprc has the same parameters as sys$forcex, but throws an exception
1893    in the target process rather than calling sys$exit.
1894
1895    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1896    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1897    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
1898    with condition codes C$_SIG0+nsig*8, catching the exception on the
1899    target process and resignaling with appropriate arguments.
1900
1901    But we don't have that VMS 7.0+ exception handler, so if you
1902    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
1903
1904    Also note that SIGTERM is listed in the docs as being "unimplemented",
1905    yet always seems to be signaled with a VMS condition code of 4 (and
1906    correctly handled for that code).  So we hardwire it in.
1907
1908    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1909    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
1910    than signalling with an unrecognized (and unhandled by CRTL) code.
1911 */
1912
1913 #define _MY_SIG_MAX 17
1914
1915 static unsigned int
1916 Perl_sig_to_vmscondition_int(int sig)
1917 {
1918     static unsigned int sig_code[_MY_SIG_MAX+1] =
1919     {
1920         0,                  /*  0 ZERO     */
1921         SS$_HANGUP,         /*  1 SIGHUP   */
1922         SS$_CONTROLC,       /*  2 SIGINT   */
1923         SS$_CONTROLY,       /*  3 SIGQUIT  */
1924         SS$_RADRMOD,        /*  4 SIGILL   */
1925         SS$_BREAK,          /*  5 SIGTRAP  */
1926         SS$_OPCCUS,         /*  6 SIGABRT  */
1927         SS$_COMPAT,         /*  7 SIGEMT   */
1928 #ifdef __VAX
1929         SS$_FLTOVF,         /*  8 SIGFPE VAX */
1930 #else
1931         SS$_HPARITH,        /*  8 SIGFPE AXP */
1932 #endif
1933         SS$_ABORT,          /*  9 SIGKILL  */
1934         SS$_ACCVIO,         /* 10 SIGBUS   */
1935         SS$_ACCVIO,         /* 11 SIGSEGV  */
1936         SS$_BADPARAM,       /* 12 SIGSYS   */
1937         SS$_NOMBX,          /* 13 SIGPIPE  */
1938         SS$_ASTFLT,         /* 14 SIGALRM  */
1939         4,                  /* 15 SIGTERM  */
1940         0,                  /* 16 SIGUSR1  */
1941         0                   /* 17 SIGUSR2  */
1942     };
1943
1944 #if __VMS_VER >= 60200000
1945     static int initted = 0;
1946     if (!initted) {
1947         initted = 1;
1948         sig_code[16] = C$_SIGUSR1;
1949         sig_code[17] = C$_SIGUSR2;
1950     }
1951 #endif
1952
1953     if (sig < _SIG_MIN) return 0;
1954     if (sig > _MY_SIG_MAX) return 0;
1955     return sig_code[sig];
1956 }
1957
1958 unsigned int
1959 Perl_sig_to_vmscondition(int sig)
1960 {
1961 #ifdef SS$_DEBUG
1962     if (vms_debug_on_exception != 0)
1963         lib$signal(SS$_DEBUG);
1964 #endif
1965     return Perl_sig_to_vmscondition_int(sig);
1966 }
1967
1968
1969 int
1970 Perl_my_kill(int pid, int sig)
1971 {
1972     dTHX;
1973     int iss;
1974     unsigned int code;
1975     int sys$sigprc(unsigned int *pidadr,
1976                      struct dsc$descriptor_s *prcname,
1977                      unsigned int code);
1978
1979      /* sig 0 means validate the PID */
1980     /*------------------------------*/
1981     if (sig == 0) {
1982         const unsigned long int jpicode = JPI$_PID;
1983         pid_t ret_pid;
1984         int status;
1985         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
1986         if ($VMS_STATUS_SUCCESS(status))
1987            return 0;
1988         switch (status) {
1989         case SS$_NOSUCHNODE:
1990         case SS$_UNREACHABLE:
1991         case SS$_NONEXPR:
1992            errno = ESRCH;
1993            break;
1994         case SS$_NOPRIV:
1995            errno = EPERM;
1996            break;
1997         default:
1998            errno = EVMSERR;
1999         }
2000         vaxc$errno=status;
2001         return -1;
2002     }
2003
2004     code = Perl_sig_to_vmscondition_int(sig);
2005
2006     if (!code) {
2007         SETERRNO(EINVAL, SS$_BADPARAM);
2008         return -1;
2009     }
2010
2011     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2012      * signals are to be sent to multiple processes.
2013      *  pid = 0 - all processes in group except ones that the system exempts
2014      *  pid = -1 - all processes except ones that the system exempts
2015      *  pid = -n - all processes in group (abs(n)) except ...
2016      * For now, just report as not supported.
2017      */
2018
2019     if (pid <= 0) {
2020         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2021         return -1;
2022     }
2023
2024     iss = sys$sigprc((unsigned int *)&pid,0,code);
2025     if (iss&1) return 0;
2026
2027     switch (iss) {
2028       case SS$_NOPRIV:
2029         set_errno(EPERM);  break;
2030       case SS$_NONEXPR:
2031       case SS$_NOSUCHNODE:
2032       case SS$_UNREACHABLE:
2033         set_errno(ESRCH);  break;
2034       case SS$_INSFMEM:
2035         set_errno(ENOMEM); break;
2036       default:
2037         _ckvmssts(iss);
2038         set_errno(EVMSERR);
2039     }
2040     set_vaxc_errno(iss);
2041
2042     return -1;
2043 }
2044 #endif
2045
2046 /* Routine to convert a VMS status code to a UNIX status code.
2047 ** More tricky than it appears because of conflicting conventions with
2048 ** existing code.
2049 **
2050 ** VMS status codes are a bit mask, with the least significant bit set for
2051 ** success.
2052 **
2053 ** Special UNIX status of EVMSERR indicates that no translation is currently
2054 ** available, and programs should check the VMS status code.
2055 **
2056 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2057 ** decoding.
2058 */
2059
2060 #ifndef C_FACILITY_NO
2061 #define C_FACILITY_NO 0x350000
2062 #endif
2063 #ifndef DCL_IVVERB
2064 #define DCL_IVVERB 0x38090
2065 #endif
2066
2067 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2068 {
2069 int facility;
2070 int fac_sp;
2071 int msg_no;
2072 int msg_status;
2073 int unix_status;
2074
2075   /* Assume the best or the worst */
2076   if (vms_status & STS$M_SUCCESS)
2077     unix_status = 0;
2078   else
2079     unix_status = EVMSERR;
2080
2081   msg_status = vms_status & ~STS$M_CONTROL;
2082
2083   facility = vms_status & STS$M_FAC_NO;
2084   fac_sp = vms_status & STS$M_FAC_SP;
2085   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2086
2087   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2088     switch(msg_no) {
2089     case SS$_NORMAL:
2090         unix_status = 0;
2091         break;
2092     case SS$_ACCVIO:
2093         unix_status = EFAULT;
2094         break;
2095     case SS$_DEVOFFLINE:
2096         unix_status = EBUSY;
2097         break;
2098     case SS$_CLEARED:
2099         unix_status = ENOTCONN;
2100         break;
2101     case SS$_IVCHAN:
2102     case SS$_IVLOGNAM:
2103     case SS$_BADPARAM:
2104     case SS$_IVLOGTAB:
2105     case SS$_NOLOGNAM:
2106     case SS$_NOLOGTAB:
2107     case SS$_INVFILFOROP:
2108     case SS$_INVARG:
2109     case SS$_NOSUCHID:
2110     case SS$_IVIDENT:
2111         unix_status = EINVAL;
2112         break;
2113     case SS$_UNSUPPORTED:
2114         unix_status = ENOTSUP;
2115         break;
2116     case SS$_FILACCERR:
2117     case SS$_NOGRPPRV:
2118     case SS$_NOSYSPRV:
2119         unix_status = EACCES;
2120         break;
2121     case SS$_DEVICEFULL:
2122         unix_status = ENOSPC;
2123         break;
2124     case SS$_NOSUCHDEV:
2125         unix_status = ENODEV;
2126         break;
2127     case SS$_NOSUCHFILE:
2128     case SS$_NOSUCHOBJECT:
2129         unix_status = ENOENT;
2130         break;
2131     case SS$_ABORT:                                 /* Fatal case */
2132     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2133     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2134         unix_status = EINTR;
2135         break;
2136     case SS$_BUFFEROVF:
2137         unix_status = E2BIG;
2138         break;
2139     case SS$_INSFMEM:
2140         unix_status = ENOMEM;
2141         break;
2142     case SS$_NOPRIV:
2143         unix_status = EPERM;
2144         break;
2145     case SS$_NOSUCHNODE:
2146     case SS$_UNREACHABLE:
2147         unix_status = ESRCH;
2148         break;
2149     case SS$_NONEXPR:
2150         unix_status = ECHILD;
2151         break;
2152     default:
2153         if ((facility == 0) && (msg_no < 8)) {
2154           /* These are not real VMS status codes so assume that they are
2155           ** already UNIX status codes
2156           */
2157           unix_status = msg_no;
2158           break;
2159         }
2160     }
2161   }
2162   else {
2163     /* Translate a POSIX exit code to a UNIX exit code */
2164     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2165         unix_status = (msg_no & 0x07F8) >> 3;
2166     }
2167     else {
2168
2169          /* Documented traditional behavior for handling VMS child exits */
2170         /*--------------------------------------------------------------*/
2171         if (child_flag != 0) {
2172
2173              /* Success / Informational return 0 */
2174             /*----------------------------------*/
2175             if (msg_no & STS$K_SUCCESS)
2176                 return 0;
2177
2178              /* Warning returns 1 */
2179             /*-------------------*/
2180             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2181                 return 1;
2182
2183              /* Everything else pass through the severity bits */
2184             /*------------------------------------------------*/
2185             return (msg_no & STS$M_SEVERITY);
2186         }
2187
2188          /* Normal VMS status to ERRNO mapping attempt */
2189         /*--------------------------------------------*/
2190         switch(msg_status) {
2191         /* case RMS$_EOF: */ /* End of File */
2192         case RMS$_FNF:  /* File Not Found */
2193         case RMS$_DNF:  /* Dir Not Found */
2194                 unix_status = ENOENT;
2195                 break;
2196         case RMS$_RNF:  /* Record Not Found */
2197                 unix_status = ESRCH;
2198                 break;
2199         case RMS$_DIR:
2200                 unix_status = ENOTDIR;
2201                 break;
2202         case RMS$_DEV:
2203                 unix_status = ENODEV;
2204                 break;
2205         case RMS$_IFI:
2206         case RMS$_FAC:
2207         case RMS$_ISI:
2208                 unix_status = EBADF;
2209                 break;
2210         case RMS$_FEX:
2211                 unix_status = EEXIST;
2212                 break;
2213         case RMS$_SYN:
2214         case RMS$_FNM:
2215         case LIB$_INVSTRDES:
2216         case LIB$_INVARG:
2217         case LIB$_NOSUCHSYM:
2218         case LIB$_INVSYMNAM:
2219         case DCL_IVVERB:
2220                 unix_status = EINVAL;
2221                 break;
2222         case CLI$_BUFOVF:
2223         case RMS$_RTB:
2224         case CLI$_TKNOVF:
2225         case CLI$_RSLOVF:
2226                 unix_status = E2BIG;
2227                 break;
2228         case RMS$_PRV:  /* No privilege */
2229         case RMS$_ACC:  /* ACP file access failed */
2230         case RMS$_WLK:  /* Device write locked */
2231                 unix_status = EACCES;
2232                 break;
2233         /* case RMS$_NMF: */  /* No more files */
2234         }
2235     }
2236   }
2237
2238   return unix_status;
2239 }
2240
2241 /* Try to guess at what VMS error status should go with a UNIX errno
2242  * value.  This is hard to do as there could be many possible VMS
2243  * error statuses that caused the errno value to be set.
2244  */
2245
2246 int Perl_unix_status_to_vms(int unix_status)
2247 {
2248 int test_unix_status;
2249
2250      /* Trivial cases first */
2251     /*---------------------*/
2252     if (unix_status == EVMSERR)
2253         return vaxc$errno;
2254
2255      /* Is vaxc$errno sane? */
2256     /*---------------------*/
2257     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2258     if (test_unix_status == unix_status)
2259         return vaxc$errno;
2260
2261      /* If way out of range, must be VMS code already */
2262     /*-----------------------------------------------*/
2263     if (unix_status > EVMSERR)
2264         return unix_status;
2265
2266      /* If out of range, punt */
2267     /*-----------------------*/
2268     if (unix_status > __ERRNO_MAX)
2269         return SS$_ABORT;
2270
2271
2272      /* Ok, now we have to do it the hard way. */
2273     /*----------------------------------------*/
2274     switch(unix_status) {
2275     case 0:     return SS$_NORMAL;
2276     case EPERM: return SS$_NOPRIV;
2277     case ENOENT: return SS$_NOSUCHOBJECT;
2278     case ESRCH: return SS$_UNREACHABLE;
2279     case EINTR: return SS$_ABORT;
2280     /* case EIO: */
2281     /* case ENXIO:  */
2282     case E2BIG: return SS$_BUFFEROVF;
2283     /* case ENOEXEC */
2284     case EBADF: return RMS$_IFI;
2285     case ECHILD: return SS$_NONEXPR;
2286     /* case EAGAIN */
2287     case ENOMEM: return SS$_INSFMEM;
2288     case EACCES: return SS$_FILACCERR;
2289     case EFAULT: return SS$_ACCVIO;
2290     /* case ENOTBLK */
2291     case EBUSY: return SS$_DEVOFFLINE;
2292     case EEXIST: return RMS$_FEX;
2293     /* case EXDEV */
2294     case ENODEV: return SS$_NOSUCHDEV;
2295     case ENOTDIR: return RMS$_DIR;
2296     /* case EISDIR */
2297     case EINVAL: return SS$_INVARG;
2298     /* case ENFILE */
2299     /* case EMFILE */
2300     /* case ENOTTY */
2301     /* case ETXTBSY */
2302     /* case EFBIG */
2303     case ENOSPC: return SS$_DEVICEFULL;
2304     case ESPIPE: return LIB$_INVARG;
2305     /* case EROFS: */
2306     /* case EMLINK: */
2307     /* case EPIPE: */
2308     /* case EDOM */
2309     case ERANGE: return LIB$_INVARG;
2310     /* case EWOULDBLOCK */
2311     /* case EINPROGRESS */
2312     /* case EALREADY */
2313     /* case ENOTSOCK */
2314     /* case EDESTADDRREQ */
2315     /* case EMSGSIZE */
2316     /* case EPROTOTYPE */
2317     /* case ENOPROTOOPT */
2318     /* case EPROTONOSUPPORT */
2319     /* case ESOCKTNOSUPPORT */
2320     /* case EOPNOTSUPP */
2321     /* case EPFNOSUPPORT */
2322     /* case EAFNOSUPPORT */
2323     /* case EADDRINUSE */
2324     /* case EADDRNOTAVAIL */
2325     /* case ENETDOWN */
2326     /* case ENETUNREACH */
2327     /* case ENETRESET */
2328     /* case ECONNABORTED */
2329     /* case ECONNRESET */
2330     /* case ENOBUFS */
2331     /* case EISCONN */
2332     case ENOTCONN: return SS$_CLEARED;
2333     /* case ESHUTDOWN */
2334     /* case ETOOMANYREFS */
2335     /* case ETIMEDOUT */
2336     /* case ECONNREFUSED */
2337     /* case ELOOP */
2338     /* case ENAMETOOLONG */
2339     /* case EHOSTDOWN */
2340     /* case EHOSTUNREACH */
2341     /* case ENOTEMPTY */
2342     /* case EPROCLIM */
2343     /* case EUSERS  */
2344     /* case EDQUOT  */
2345     /* case ENOMSG  */
2346     /* case EIDRM */
2347     /* case EALIGN */
2348     /* case ESTALE */
2349     /* case EREMOTE */
2350     /* case ENOLCK */
2351     /* case ENOSYS */
2352     /* case EFTYPE */
2353     /* case ECANCELED */
2354     /* case EFAIL */
2355     /* case EINPROG */
2356     case ENOTSUP:
2357         return SS$_UNSUPPORTED;
2358     /* case EDEADLK */
2359     /* case ENWAIT */
2360     /* case EILSEQ */
2361     /* case EBADCAT */
2362     /* case EBADMSG */
2363     /* case EABANDONED */
2364     default:
2365         return SS$_ABORT; /* punt */
2366     }
2367
2368   return SS$_ABORT; /* Should not get here */
2369 }
2370
2371
2372 /* default piping mailbox size */
2373 #define PERL_BUFSIZ        512
2374
2375
2376 static void
2377 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2378 {
2379   unsigned long int mbxbufsiz;
2380   static unsigned long int syssize = 0;
2381   unsigned long int dviitm = DVI$_DEVNAM;
2382   char csize[LNM$C_NAMLENGTH+1];
2383   int sts;
2384
2385   if (!syssize) {
2386     unsigned long syiitm = SYI$_MAXBUF;
2387     /*
2388      * Get the SYSGEN parameter MAXBUF
2389      *
2390      * If the logical 'PERL_MBX_SIZE' is defined
2391      * use the value of the logical instead of PERL_BUFSIZ, but
2392      * keep the size between 128 and MAXBUF.
2393      *
2394      */
2395     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2396   }
2397
2398   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2399       mbxbufsiz = atoi(csize);
2400   } else {
2401       mbxbufsiz = PERL_BUFSIZ;
2402   }
2403   if (mbxbufsiz < 128) mbxbufsiz = 128;
2404   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2405
2406   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2407
2408   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2409   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2410
2411 }  /* end of create_mbx() */
2412
2413
2414 /*{{{  my_popen and my_pclose*/
2415
2416 typedef struct _iosb           IOSB;
2417 typedef struct _iosb*         pIOSB;
2418 typedef struct _pipe           Pipe;
2419 typedef struct _pipe*         pPipe;
2420 typedef struct pipe_details    Info;
2421 typedef struct pipe_details*  pInfo;
2422 typedef struct _srqp            RQE;
2423 typedef struct _srqp*          pRQE;
2424 typedef struct _tochildbuf      CBuf;
2425 typedef struct _tochildbuf*    pCBuf;
2426
2427 struct _iosb {
2428     unsigned short status;
2429     unsigned short count;
2430     unsigned long  dvispec;
2431 };
2432
2433 #pragma member_alignment save
2434 #pragma nomember_alignment quadword
2435 struct _srqp {          /* VMS self-relative queue entry */
2436     unsigned long qptr[2];
2437 };
2438 #pragma member_alignment restore
2439 static RQE  RQE_ZERO = {0,0};
2440
2441 struct _tochildbuf {
2442     RQE             q;
2443     int             eof;
2444     unsigned short  size;
2445     char            *buf;
2446 };
2447
2448 struct _pipe {
2449     RQE            free;
2450     RQE            wait;
2451     int            fd_out;
2452     unsigned short chan_in;
2453     unsigned short chan_out;
2454     char          *buf;
2455     unsigned int   bufsize;
2456     IOSB           iosb;
2457     IOSB           iosb2;
2458     int           *pipe_done;
2459     int            retry;
2460     int            type;
2461     int            shut_on_empty;
2462     int            need_wake;
2463     pPipe         *home;
2464     pInfo          info;
2465     pCBuf          curr;
2466     pCBuf          curr2;
2467 #if defined(PERL_IMPLICIT_CONTEXT)
2468     void            *thx;           /* Either a thread or an interpreter */
2469                                     /* pointer, depending on how we're built */
2470 #endif
2471 };
2472
2473
2474 struct pipe_details
2475 {
2476     pInfo           next;
2477     PerlIO *fp;  /* file pointer to pipe mailbox */
2478     int useFILE; /* using stdio, not perlio */
2479     int pid;   /* PID of subprocess */
2480     int mode;  /* == 'r' if pipe open for reading */
2481     int done;  /* subprocess has completed */
2482     int waiting; /* waiting for completion/closure */
2483     int             closing;        /* my_pclose is closing this pipe */
2484     unsigned long   completion;     /* termination status of subprocess */
2485     pPipe           in;             /* pipe in to sub */
2486     pPipe           out;            /* pipe out of sub */
2487     pPipe           err;            /* pipe of sub's sys$error */
2488     int             in_done;        /* true when in pipe finished */
2489     int             out_done;
2490     int             err_done;
2491 };
2492
2493 struct exit_control_block
2494 {
2495     struct exit_control_block *flink;
2496     unsigned long int   (*exit_routine)();
2497     unsigned long int arg_count;
2498     unsigned long int *status_address;
2499     unsigned long int exit_status;
2500 };
2501
2502 typedef struct _closed_pipes    Xpipe;
2503 typedef struct _closed_pipes*  pXpipe;
2504
2505 struct _closed_pipes {
2506     int             pid;            /* PID of subprocess */
2507     unsigned long   completion;     /* termination status of subprocess */
2508 };
2509 #define NKEEPCLOSED 50
2510 static Xpipe closed_list[NKEEPCLOSED];
2511 static int   closed_index = 0;
2512 static int   closed_num = 0;
2513
2514 #define RETRY_DELAY     "0 ::0.20"
2515 #define MAX_RETRY              50
2516
2517 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2518 static unsigned long mypid;
2519 static unsigned long delaytime[2];
2520
2521 static pInfo open_pipes = NULL;
2522 static $DESCRIPTOR(nl_desc, "NL:");
2523
2524 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2525
2526
2527
2528 static unsigned long int
2529 pipe_exit_routine(pTHX)
2530 {
2531     pInfo info;
2532     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2533     int sts, did_stuff, need_eof, j;
2534
2535     /*
2536         flush any pending i/o
2537     */
2538     info = open_pipes;
2539     while (info) {
2540         if (info->fp) {
2541            if (!info->useFILE)
2542                PerlIO_flush(info->fp);   /* first, flush data */
2543            else
2544                fflush((FILE *)info->fp);
2545         }
2546         info = info->next;
2547     }
2548
2549     /*
2550      next we try sending an EOF...ignore if doesn't work, make sure we
2551      don't hang
2552     */
2553     did_stuff = 0;
2554     info = open_pipes;
2555
2556     while (info) {
2557       int need_eof;
2558       _ckvmssts_noperl(sys$setast(0));
2559       if (info->in && !info->in->shut_on_empty) {
2560         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2561                           0, 0, 0, 0, 0, 0));
2562         info->waiting = 1;
2563         did_stuff = 1;
2564       }
2565       _ckvmssts_noperl(sys$setast(1));
2566       info = info->next;
2567     }
2568
2569     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2570
2571     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2572         int nwait = 0;
2573
2574         info = open_pipes;
2575         while (info) {
2576           _ckvmssts_noperl(sys$setast(0));
2577           if (info->waiting && info->done)
2578                 info->waiting = 0;
2579           nwait += info->waiting;
2580           _ckvmssts_noperl(sys$setast(1));
2581           info = info->next;
2582         }
2583         if (!nwait) break;
2584         sleep(1);
2585     }
2586
2587     did_stuff = 0;
2588     info = open_pipes;
2589     while (info) {
2590       _ckvmssts_noperl(sys$setast(0));
2591       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2592         sts = sys$forcex(&info->pid,0,&abort);
2593         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2594         did_stuff = 1;
2595       }
2596       _ckvmssts_noperl(sys$setast(1));
2597       info = info->next;
2598     }
2599
2600     /* again, wait for effect */
2601
2602     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2603         int nwait = 0;
2604
2605         info = open_pipes;
2606         while (info) {
2607           _ckvmssts_noperl(sys$setast(0));
2608           if (info->waiting && info->done)
2609                 info->waiting = 0;
2610           nwait += info->waiting;
2611           _ckvmssts_noperl(sys$setast(1));
2612           info = info->next;
2613         }
2614         if (!nwait) break;
2615         sleep(1);
2616     }
2617
2618     info = open_pipes;
2619     while (info) {
2620       _ckvmssts_noperl(sys$setast(0));
2621       if (!info->done) {  /* We tried to be nice . . . */
2622         sts = sys$delprc(&info->pid,0);
2623         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2624       }
2625       _ckvmssts_noperl(sys$setast(1));
2626       info = info->next;
2627     }
2628
2629     while(open_pipes) {
2630       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2631       else if (!(sts & 1)) retsts = sts;
2632     }
2633     return retsts;
2634 }
2635
2636 static struct exit_control_block pipe_exitblock =
2637        {(struct exit_control_block *) 0,
2638         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2639
2640 static void pipe_mbxtofd_ast(pPipe p);
2641 static void pipe_tochild1_ast(pPipe p);
2642 static void pipe_tochild2_ast(pPipe p);
2643
2644 static void
2645 popen_completion_ast(pInfo info)
2646 {
2647   pInfo i = open_pipes;
2648   int iss;
2649   int sts;
2650   pXpipe x;
2651
2652   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2653   closed_list[closed_index].pid = info->pid;
2654   closed_list[closed_index].completion = info->completion;
2655   closed_index++;
2656   if (closed_index == NKEEPCLOSED)
2657     closed_index = 0;
2658   closed_num++;
2659
2660   while (i) {
2661     if (i == info) break;
2662     i = i->next;
2663   }
2664   if (!i) return;       /* unlinked, probably freed too */
2665
2666   info->done = TRUE;
2667
2668 /*
2669     Writing to subprocess ...
2670             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2671
2672             chan_out may be waiting for "done" flag, or hung waiting
2673             for i/o completion to child...cancel the i/o.  This will
2674             put it into "snarf mode" (done but no EOF yet) that discards
2675             input.
2676
2677     Output from subprocess (stdout, stderr) needs to be flushed and
2678     shut down.   We try sending an EOF, but if the mbx is full the pipe
2679     routine should still catch the "shut_on_empty" flag, telling it to
2680     use immediate-style reads so that "mbx empty" -> EOF.
2681
2682
2683 */
2684   if (info->in && !info->in_done) {               /* only for mode=w */
2685         if (info->in->shut_on_empty && info->in->need_wake) {
2686             info->in->need_wake = FALSE;
2687             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2688         } else {
2689             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2690         }
2691   }
2692
2693   if (info->out && !info->out_done) {             /* were we also piping output? */
2694       info->out->shut_on_empty = TRUE;
2695       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2696       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2697       _ckvmssts_noperl(iss);
2698   }
2699
2700   if (info->err && !info->err_done) {        /* we were piping stderr */
2701         info->err->shut_on_empty = TRUE;
2702         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2703         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2704         _ckvmssts_noperl(iss);
2705   }
2706   _ckvmssts_noperl(sys$setef(pipe_ef));
2707
2708 }
2709
2710 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2711 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2712
2713 /*
2714     we actually differ from vmstrnenv since we use this to
2715     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2716     are pointing to the same thing
2717 */
2718
2719 static unsigned short
2720 popen_translate(pTHX_ char *logical, char *result)
2721 {
2722     int iss;
2723     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2724     $DESCRIPTOR(d_log,"");
2725     struct _il3 {
2726         unsigned short length;
2727         unsigned short code;
2728         char *         buffer_addr;
2729         unsigned short *retlenaddr;
2730     } itmlst[2];
2731     unsigned short l, ifi;
2732
2733     d_log.dsc$a_pointer = logical;
2734     d_log.dsc$w_length  = strlen(logical);
2735
2736     itmlst[0].code = LNM$_STRING;
2737     itmlst[0].length = 255;
2738     itmlst[0].buffer_addr = result;
2739     itmlst[0].retlenaddr = &l;
2740
2741     itmlst[1].code = 0;
2742     itmlst[1].length = 0;
2743     itmlst[1].buffer_addr = 0;
2744     itmlst[1].retlenaddr = 0;
2745
2746     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2747     if (iss == SS$_NOLOGNAM) {
2748         iss = SS$_NORMAL;
2749         l = 0;
2750     }
2751     if (!(iss&1)) lib$signal(iss);
2752     result[l] = '\0';
2753 /*
2754     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
2755     strip it off and return the ifi, if any
2756 */
2757     ifi  = 0;
2758     if (result[0] == 0x1b && result[1] == 0x00) {
2759         memmove(&ifi,result+2,2);
2760         strcpy(result,result+4);
2761     }
2762     return ifi;     /* this is the RMS internal file id */
2763 }
2764
2765 static void pipe_infromchild_ast(pPipe p);
2766
2767 /*
2768     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2769     inside an AST routine without worrying about reentrancy and which Perl
2770     memory allocator is being used.
2771
2772     We read data and queue up the buffers, then spit them out one at a
2773     time to the output mailbox when the output mailbox is ready for one.
2774
2775 */
2776 #define INITIAL_TOCHILDQUEUE  2
2777
2778 static pPipe
2779 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2780 {
2781     pPipe p;
2782     pCBuf b;
2783     char mbx1[64], mbx2[64];
2784     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2785                                       DSC$K_CLASS_S, mbx1},
2786                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2787                                       DSC$K_CLASS_S, mbx2};
2788     unsigned int dviitm = DVI$_DEVBUFSIZ;
2789     int j, n;
2790
2791     n = sizeof(Pipe);
2792     _ckvmssts(lib$get_vm(&n, &p));
2793
2794     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2795     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2796     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2797
2798     p->buf           = 0;
2799     p->shut_on_empty = FALSE;
2800     p->need_wake     = FALSE;
2801     p->type          = 0;
2802     p->retry         = 0;
2803     p->iosb.status   = SS$_NORMAL;
2804     p->iosb2.status  = SS$_NORMAL;
2805     p->free          = RQE_ZERO;
2806     p->wait          = RQE_ZERO;
2807     p->curr          = 0;
2808     p->curr2         = 0;
2809     p->info          = 0;
2810 #ifdef PERL_IMPLICIT_CONTEXT
2811     p->thx           = aTHX;
2812 #endif
2813
2814     n = sizeof(CBuf) + p->bufsize;
2815
2816     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2817         _ckvmssts(lib$get_vm(&n, &b));
2818         b->buf = (char *) b + sizeof(CBuf);
2819         _ckvmssts(lib$insqhi(b, &p->free));
2820     }
2821
2822     pipe_tochild2_ast(p);
2823     pipe_tochild1_ast(p);
2824     strcpy(wmbx, mbx1);
2825     strcpy(rmbx, mbx2);
2826     return p;
2827 }
2828
2829 /*  reads the MBX Perl is writing, and queues */
2830
2831 static void
2832 pipe_tochild1_ast(pPipe p)
2833 {
2834     pCBuf b = p->curr;
2835     int iss = p->iosb.status;
2836     int eof = (iss == SS$_ENDOFFILE);
2837     int sts;
2838 #ifdef PERL_IMPLICIT_CONTEXT
2839     pTHX = p->thx;
2840 #endif
2841
2842     if (p->retry) {
2843         if (eof) {
2844             p->shut_on_empty = TRUE;
2845             b->eof     = TRUE;
2846             _ckvmssts(sys$dassgn(p->chan_in));
2847         } else  {
2848             _ckvmssts(iss);
2849         }
2850
2851         b->eof  = eof;
2852         b->size = p->iosb.count;
2853         _ckvmssts(sts = lib$insqhi(b, &p->wait));
2854         if (p->need_wake) {
2855             p->need_wake = FALSE;
2856             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2857         }
2858     } else {
2859         p->retry = 1;   /* initial call */
2860     }
2861
2862     if (eof) {                  /* flush the free queue, return when done */
2863         int n = sizeof(CBuf) + p->bufsize;
2864         while (1) {
2865             iss = lib$remqti(&p->free, &b);
2866             if (iss == LIB$_QUEWASEMP) return;
2867             _ckvmssts(iss);
2868             _ckvmssts(lib$free_vm(&n, &b));
2869         }
2870     }
2871
2872     iss = lib$remqti(&p->free, &b);
2873     if (iss == LIB$_QUEWASEMP) {
2874         int n = sizeof(CBuf) + p->bufsize;
2875         _ckvmssts(lib$get_vm(&n, &b));
2876         b->buf = (char *) b + sizeof(CBuf);
2877     } else {
2878        _ckvmssts(iss);
2879     }
2880
2881     p->curr = b;
2882     iss = sys$qio(0,p->chan_in,
2883              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2884              &p->iosb,
2885              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2886     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2887     _ckvmssts(iss);
2888 }
2889
2890
2891 /* writes queued buffers to output, waits for each to complete before
2892    doing the next */
2893
2894 static void
2895 pipe_tochild2_ast(pPipe p)
2896 {
2897     pCBuf b = p->curr2;
2898     int iss = p->iosb2.status;
2899     int n = sizeof(CBuf) + p->bufsize;
2900     int done = (p->info && p->info->done) ||
2901               iss == SS$_CANCEL || iss == SS$_ABORT;
2902 #if defined(PERL_IMPLICIT_CONTEXT)
2903     pTHX = p->thx;
2904 #endif
2905
2906     do {
2907         if (p->type) {         /* type=1 has old buffer, dispose */
2908             if (p->shut_on_empty) {
2909                 _ckvmssts(lib$free_vm(&n, &b));
2910             } else {
2911                 _ckvmssts(lib$insqhi(b, &p->free));
2912             }
2913             p->type = 0;
2914         }
2915
2916         iss = lib$remqti(&p->wait, &b);
2917         if (iss == LIB$_QUEWASEMP) {
2918             if (p->shut_on_empty) {
2919                 if (done) {
2920                     _ckvmssts(sys$dassgn(p->chan_out));
2921                     *p->pipe_done = TRUE;
2922                     _ckvmssts(sys$setef(pipe_ef));
2923                 } else {
2924                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2925                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2926                 }
2927                 return;
2928             }
2929             p->need_wake = TRUE;
2930             return;
2931         }
2932         _ckvmssts(iss);
2933         p->type = 1;
2934     } while (done);
2935
2936
2937     p->curr2 = b;
2938     if (b->eof) {
2939         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2940             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2941     } else {
2942         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2943             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2944     }
2945
2946     return;
2947
2948 }
2949
2950
2951 static pPipe
2952 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2953 {
2954     pPipe p;
2955     char mbx1[64], mbx2[64];
2956     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2957                                       DSC$K_CLASS_S, mbx1},
2958                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2959                                       DSC$K_CLASS_S, mbx2};
2960     unsigned int dviitm = DVI$_DEVBUFSIZ;
2961
2962     int n = sizeof(Pipe);
2963     _ckvmssts(lib$get_vm(&n, &p));
2964     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2965     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2966
2967     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2968     n = p->bufsize * sizeof(char);
2969     _ckvmssts(lib$get_vm(&n, &p->buf));
2970     p->shut_on_empty = FALSE;
2971     p->info   = 0;
2972     p->type   = 0;
2973     p->iosb.status = SS$_NORMAL;
2974 #if defined(PERL_IMPLICIT_CONTEXT)
2975     p->thx = aTHX;
2976 #endif
2977     pipe_infromchild_ast(p);
2978
2979     strcpy(wmbx, mbx1);
2980     strcpy(rmbx, mbx2);
2981     return p;
2982 }
2983
2984 static void
2985 pipe_infromchild_ast(pPipe p)
2986 {
2987     int iss = p->iosb.status;
2988     int eof = (iss == SS$_ENDOFFILE);
2989     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2990     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2991 #if defined(PERL_IMPLICIT_CONTEXT)
2992     pTHX = p->thx;
2993 #endif
2994
2995     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
2996         _ckvmssts(sys$dassgn(p->chan_out));
2997         p->chan_out = 0;
2998     }
2999
3000     /* read completed:
3001             input shutdown if EOF from self (done or shut_on_empty)
3002             output shutdown if closing flag set (my_pclose)
3003             send data/eof from child or eof from self
3004             otherwise, re-read (snarf of data from child)
3005     */
3006
3007     if (p->type == 1) {
3008         p->type = 0;
3009         if (myeof && p->chan_in) {                  /* input shutdown */
3010             _ckvmssts(sys$dassgn(p->chan_in));
3011             p->chan_in = 0;
3012         }
3013
3014         if (p->chan_out) {
3015             if (myeof || kideof) {      /* pass EOF to parent */
3016                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3017                               pipe_infromchild_ast, p,
3018                               0, 0, 0, 0, 0, 0));
3019                 return;
3020             } else if (eof) {       /* eat EOF --- fall through to read*/
3021
3022             } else {                /* transmit data */
3023                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3024                               pipe_infromchild_ast,p,
3025                               p->buf, p->iosb.count, 0, 0, 0, 0));
3026                 return;
3027             }
3028         }
3029     }
3030
3031     /*  everything shut? flag as done */
3032
3033     if (!p->chan_in && !p->chan_out) {
3034         *p->pipe_done = TRUE;
3035         _ckvmssts(sys$setef(pipe_ef));
3036         return;
3037     }
3038
3039     /* write completed (or read, if snarfing from child)
3040             if still have input active,
3041                queue read...immediate mode if shut_on_empty so we get EOF if empty
3042             otherwise,
3043                check if Perl reading, generate EOFs as needed
3044     */
3045
3046     if (p->type == 0) {
3047         p->type = 1;
3048         if (p->chan_in) {
3049             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3050                           pipe_infromchild_ast,p,
3051                           p->buf, p->bufsize, 0, 0, 0, 0);
3052             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3053             _ckvmssts(iss);
3054         } else {           /* send EOFs for extra reads */
3055             p->iosb.status = SS$_ENDOFFILE;
3056             p->iosb.dvispec = 0;
3057             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3058                       0, 0, 0,
3059                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3060         }
3061     }
3062 }
3063
3064 static pPipe
3065 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3066 {
3067     pPipe p;
3068     char mbx[64];
3069     unsigned long dviitm = DVI$_DEVBUFSIZ;
3070     struct stat s;
3071     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3072                                       DSC$K_CLASS_S, mbx};
3073     int n = sizeof(Pipe);
3074
3075     /* things like terminals and mbx's don't need this filter */
3076     if (fd && fstat(fd,&s) == 0) {
3077         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3078         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
3079                                          DSC$K_CLASS_S, s.st_dev};
3080
3081         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
3082         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
3083             strcpy(out, s.st_dev);
3084             return 0;
3085         }
3086     }
3087
3088     _ckvmssts(lib$get_vm(&n, &p));
3089     p->fd_out = dup(fd);
3090     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3091     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3092     n = (p->bufsize+1) * sizeof(char);
3093     _ckvmssts(lib$get_vm(&n, &p->buf));
3094     p->shut_on_empty = FALSE;
3095     p->retry = 0;
3096     p->info  = 0;
3097     strcpy(out, mbx);
3098
3099     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3100                   pipe_mbxtofd_ast, p,
3101                   p->buf, p->bufsize, 0, 0, 0, 0));
3102
3103     return p;
3104 }
3105
3106 static void
3107 pipe_mbxtofd_ast(pPipe p)
3108 {
3109     int iss = p->iosb.status;
3110     int done = p->info->done;
3111     int iss2;
3112     int eof = (iss == SS$_ENDOFFILE);
3113     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3114     int err = !(iss&1) && !eof;
3115 #if defined(PERL_IMPLICIT_CONTEXT)
3116     pTHX = p->thx;
3117 #endif
3118
3119     if (done && myeof) {               /* end piping */
3120         close(p->fd_out);
3121         sys$dassgn(p->chan_in);
3122         *p->pipe_done = TRUE;
3123         _ckvmssts(sys$setef(pipe_ef));
3124         return;
3125     }
3126
3127     if (!err && !eof) {             /* good data to send to file */
3128         p->buf[p->iosb.count] = '\n';
3129         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3130         if (iss2 < 0) {
3131             p->retry++;
3132             if (p->retry < MAX_RETRY) {
3133                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3134                 return;
3135             }
3136         }
3137         p->retry = 0;
3138     } else if (err) {
3139         _ckvmssts(iss);
3140     }
3141
3142
3143     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3144           pipe_mbxtofd_ast, p,
3145           p->buf, p->bufsize, 0, 0, 0, 0);
3146     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3147     _ckvmssts(iss);
3148 }
3149
3150
3151 typedef struct _pipeloc     PLOC;
3152 typedef struct _pipeloc*   pPLOC;
3153
3154 struct _pipeloc {
3155     pPLOC   next;
3156     char    dir[NAM$C_MAXRSS+1];
3157 };
3158 static pPLOC  head_PLOC = 0;
3159
3160 void
3161 free_pipelocs(pTHX_ void *head)
3162 {
3163     pPLOC p, pnext;
3164     pPLOC *pHead = (pPLOC *)head;
3165
3166     p = *pHead;
3167     while (p) {
3168         pnext = p->next;
3169         PerlMem_free(p);
3170         p = pnext;
3171     }
3172     *pHead = 0;
3173 }
3174
3175 static void
3176 store_pipelocs(pTHX)
3177 {
3178     int    i;
3179     pPLOC  p;
3180     AV    *av = 0;
3181     SV    *dirsv;
3182     GV    *gv;
3183     char  *dir, *x;
3184     char  *unixdir;
3185     char  temp[NAM$C_MAXRSS+1];
3186     STRLEN n_a;
3187
3188     if (head_PLOC)
3189         free_pipelocs(aTHX_ &head_PLOC);
3190
3191 /*  the . directory from @INC comes last */
3192
3193     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3194     p->next = head_PLOC;
3195     head_PLOC = p;
3196     strcpy(p->dir,"./");
3197
3198 /*  get the directory from $^X */
3199
3200 #ifdef PERL_IMPLICIT_CONTEXT
3201     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3202 #else
3203     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3204 #endif
3205         strcpy(temp, PL_origargv[0]);
3206         x = strrchr(temp,']');
3207         if (x == NULL) {
3208         x = strrchr(temp,'>');
3209           if (x == NULL) {
3210             /* It could be a UNIX path */
3211             x = strrchr(temp,'/');
3212           }
3213         }
3214         if (x)
3215           x[1] = '\0';
3216         else {
3217           /* Got a bare name, so use default directory */
3218           temp[0] = '.';
3219           temp[1] = '\0';
3220         }
3221
3222         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
3223             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3224             p->next = head_PLOC;
3225             head_PLOC = p;
3226             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3227             p->dir[NAM$C_MAXRSS] = '\0';
3228         }
3229     }
3230
3231 /*  reverse order of @INC entries, skip "." since entered above */
3232
3233 #ifdef PERL_IMPLICIT_CONTEXT
3234     if (aTHX)
3235 #endif
3236     if (PL_incgv) av = GvAVn(PL_incgv);
3237
3238     for (i = 0; av && i <= AvFILL(av); i++) {
3239         dirsv = *av_fetch(av,i,TRUE);
3240
3241         if (SvROK(dirsv)) continue;
3242         dir = SvPVx(dirsv,n_a);
3243         if (strcmp(dir,".") == 0) continue;
3244         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3245             continue;
3246
3247         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3248         p->next = head_PLOC;
3249         head_PLOC = p;
3250         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3251         p->dir[NAM$C_MAXRSS] = '\0';
3252     }
3253
3254 /* most likely spot (ARCHLIB) put first in the list */
3255
3256 #ifdef ARCHLIB_EXP
3257     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
3258         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3259         p->next = head_PLOC;
3260         head_PLOC = p;
3261         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3262         p->dir[NAM$C_MAXRSS] = '\0';
3263     }
3264 #endif
3265 }
3266
3267
3268 static char *
3269 find_vmspipe(pTHX)
3270 {
3271     static int   vmspipe_file_status = 0;
3272     static char  vmspipe_file[NAM$C_MAXRSS+1];
3273
3274     /* already found? Check and use ... need read+execute permission */
3275
3276     if (vmspipe_file_status == 1) {
3277         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3278          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3279             return vmspipe_file;
3280         }
3281         vmspipe_file_status = 0;
3282     }
3283
3284     /* scan through stored @INC, $^X */
3285
3286     if (vmspipe_file_status == 0) {
3287         char file[NAM$C_MAXRSS+1];
3288         pPLOC  p = head_PLOC;
3289
3290         while (p) {
3291             strcpy(file, p->dir);
3292             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3293             file[NAM$C_MAXRSS] = '\0';
3294             p = p->next;
3295
3296             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3297
3298             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3299              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3300                 vmspipe_file_status = 1;
3301                 return vmspipe_file;
3302             }
3303         }
3304         vmspipe_file_status = -1;   /* failed, use tempfiles */
3305     }
3306
3307     return 0;
3308 }
3309
3310 static FILE *
3311 vmspipe_tempfile(pTHX)
3312 {
3313     char file[NAM$C_MAXRSS+1];
3314     FILE *fp;
3315     static int index = 0;
3316     Stat_t s0, s1;
3317     int cmp_result;
3318
3319     /* create a tempfile */
3320
3321     /* we can't go from   W, shr=get to  R, shr=get without
3322        an intermediate vulnerable state, so don't bother trying...
3323
3324        and lib$spawn doesn't shr=put, so have to close the write
3325
3326        So... match up the creation date/time and the FID to
3327        make sure we're dealing with the same file
3328
3329     */
3330
3331     index++;
3332     if (!decc_filename_unix_only) {
3333       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3334       fp = fopen(file,"w");
3335       if (!fp) {
3336         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3337         fp = fopen(file,"w");
3338         if (!fp) {
3339             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3340             fp = fopen(file,"w");
3341         }
3342       }
3343      }
3344      else {
3345       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3346       fp = fopen(file,"w");
3347       if (!fp) {
3348         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3349         fp = fopen(file,"w");
3350         if (!fp) {
3351           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3352           fp = fopen(file,"w");
3353         }
3354       }
3355     }
3356     if (!fp) return 0;  /* we're hosed */
3357
3358     fprintf(fp,"$! 'f$verify(0)'\n");
3359     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3360     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3361     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3362     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3363     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3364     fprintf(fp,"$ perl_del    = \"delete\"\n");
3365     fprintf(fp,"$ pif         = \"if\"\n");
3366     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3367     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3368     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3369     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3370     fprintf(fp,"$!  --- build command line to get max possible length\n");
3371     fprintf(fp,"$c=perl_popen_cmd0\n");
3372     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3373     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3374     fprintf(fp,"$x=perl_popen_cmd3\n");
3375     fprintf(fp,"$c=c+x\n");
3376     fprintf(fp,"$ perl_on\n");
3377     fprintf(fp,"$ 'c'\n");
3378     fprintf(fp,"$ perl_status = $STATUS\n");
3379     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3380     fprintf(fp,"$ perl_exit 'perl_status'\n");
3381     fsync(fileno(fp));
3382
3383     fgetname(fp, file, 1);
3384     fstat(fileno(fp), (struct stat *)&s0);
3385     fclose(fp);
3386
3387     if (decc_filename_unix_only)
3388         do_tounixspec(file, file, 0);
3389     fp = fopen(file,"r","shr=get");
3390     if (!fp) return 0;
3391     fstat(fileno(fp), (struct stat *)&s1);
3392
3393     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3394     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3395         fclose(fp);
3396         return 0;
3397     }
3398
3399     return fp;
3400 }
3401
3402
3403
3404 static PerlIO *
3405 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3406 {
3407     static int handler_set_up = FALSE;
3408     unsigned long int sts, flags = CLI$M_NOWAIT;
3409     /* The use of a GLOBAL table (as was done previously) rendered
3410      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3411      * environment.  Hence we've switched to LOCAL symbol table.
3412      */
3413     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3414     int j, wait = 0, n;
3415     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3416     char in[512], out[512], err[512], mbx[512];
3417     FILE *tpipe = 0;
3418     char tfilebuf[NAM$C_MAXRSS+1];
3419     pInfo info = NULL;
3420     char cmd_sym_name[20];
3421     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3422                                       DSC$K_CLASS_S, symbol};
3423     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3424                                       DSC$K_CLASS_S, 0};
3425     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3426                                       DSC$K_CLASS_S, cmd_sym_name};
3427     struct dsc$descriptor_s *vmscmd;
3428     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3429     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3430     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3431
3432     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3433
3434     /* once-per-program initialization...
3435        note that the SETAST calls and the dual test of pipe_ef
3436        makes sure that only the FIRST thread through here does
3437        the initialization...all other threads wait until it's
3438        done.
3439
3440        Yeah, uglier than a pthread call, it's got all the stuff inline
3441        rather than in a separate routine.
3442     */
3443
3444     if (!pipe_ef) {
3445         _ckvmssts(sys$setast(0));
3446         if (!pipe_ef) {
3447             unsigned long int pidcode = JPI$_PID;
3448             $DESCRIPTOR(d_delay, RETRY_DELAY);
3449             _ckvmssts(lib$get_ef(&pipe_ef));
3450             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3451             _ckvmssts(sys$bintim(&d_delay, delaytime));
3452         }
3453         if (!handler_set_up) {
3454           _ckvmssts(sys$dclexh(&pipe_exitblock));
3455           handler_set_up = TRUE;
3456         }
3457         _ckvmssts(sys$setast(1));
3458     }
3459
3460     /* see if we can find a VMSPIPE.COM */
3461
3462     tfilebuf[0] = '@';
3463     vmspipe = find_vmspipe(aTHX);
3464     if (vmspipe) {
3465         strcpy(tfilebuf+1,vmspipe);
3466     } else {        /* uh, oh...we're in tempfile hell */
3467         tpipe = vmspipe_tempfile(aTHX);
3468         if (!tpipe) {       /* a fish popular in Boston */
3469             if (ckWARN(WARN_PIPE)) {
3470                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3471             }
3472         return Nullfp;
3473         }
3474         fgetname(tpipe,tfilebuf+1,1);
3475     }
3476     vmspipedsc.dsc$a_pointer = tfilebuf;
3477     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3478
3479     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3480     if (!(sts & 1)) {
3481       switch (sts) {
3482         case RMS$_FNF:  case RMS$_DNF:
3483           set_errno(ENOENT); break;
3484         case RMS$_DIR:
3485           set_errno(ENOTDIR); break;
3486         case RMS$_DEV:
3487           set_errno(ENODEV); break;
3488         case RMS$_PRV:
3489           set_errno(EACCES); break;
3490         case RMS$_SYN:
3491           set_errno(EINVAL); break;
3492         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3493           set_errno(E2BIG); break;
3494         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3495           _ckvmssts(sts); /* fall through */
3496         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3497           set_errno(EVMSERR);
3498       }
3499       set_vaxc_errno(sts);
3500       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3501         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3502       }
3503       *psts = sts;
3504       return Nullfp;
3505     }
3506     n = sizeof(Info);
3507     _ckvmssts(lib$get_vm(&n, &info));
3508
3509     strcpy(mode,in_mode);
3510     info->mode = *mode;
3511     info->done = FALSE;
3512     info->completion = 0;
3513     info->closing    = FALSE;
3514     info->in         = 0;
3515     info->out        = 0;
3516     info->err        = 0;
3517     info->fp         = Nullfp;
3518     info->useFILE    = 0;
3519     info->waiting    = 0;
3520     info->in_done    = TRUE;
3521     info->out_done   = TRUE;
3522     info->err_done   = TRUE;
3523     in[0] = out[0] = err[0] = '\0';
3524
3525     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3526         info->useFILE = 1;
3527         strcpy(p,p+1);
3528     }
3529     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3530         wait = 1;
3531         strcpy(p,p+1);
3532     }
3533
3534     if (*mode == 'r') {             /* piping from subroutine */
3535
3536         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3537         if (info->out) {
3538             info->out->pipe_done = &info->out_done;
3539             info->out_done = FALSE;
3540             info->out->info = info;
3541         }
3542         if (!info->useFILE) {
3543         info->fp  = PerlIO_open(mbx, mode);
3544         } else {
3545             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3546             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3547         }
3548
3549         if (!info->fp && info->out) {
3550             sys$cancel(info->out->chan_out);
3551
3552             while (!info->out_done) {
3553                 int done;
3554                 _ckvmssts(sys$setast(0));
3555                 done = info->out_done;
3556                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3557                 _ckvmssts(sys$setast(1));
3558                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3559             }
3560
3561             if (info->out->buf) {
3562                 n = info->out->bufsize * sizeof(char);
3563                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3564             }
3565             n = sizeof(Pipe);
3566             _ckvmssts(lib$free_vm(&n, &info->out));
3567             n = sizeof(Info);
3568             _ckvmssts(lib$free_vm(&n, &info));
3569             *psts = RMS$_FNF;
3570             return Nullfp;
3571         }
3572
3573         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3574         if (info->err) {
3575             info->err->pipe_done = &info->err_done;
3576             info->err_done = FALSE;
3577             info->err->info = info;
3578         }
3579
3580     } else if (*mode == 'w') {      /* piping to subroutine */
3581
3582         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3583         if (info->out) {
3584             info->out->pipe_done = &info->out_done;
3585             info->out_done = FALSE;
3586             info->out->info = info;
3587         }
3588
3589         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3590         if (info->err) {
3591             info->err->pipe_done = &info->err_done;
3592             info->err_done = FALSE;
3593             info->err->info = info;
3594         }
3595
3596         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3597         if (!info->useFILE) {
3598             info->fp  = PerlIO_open(mbx, mode);
3599         } else {
3600             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3601             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3602         }
3603
3604         if (info->in) {
3605             info->in->pipe_done = &info->in_done;
3606             info->in_done = FALSE;
3607             info->in->info = info;
3608         }
3609
3610         /* error cleanup */
3611         if (!info->fp && info->in) {
3612             info->done = TRUE;
3613             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3614                               0, 0, 0, 0, 0, 0, 0, 0));
3615
3616             while (!info->in_done) {
3617                 int done;
3618                 _ckvmssts(sys$setast(0));
3619                 done = info->in_done;
3620                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3621                 _ckvmssts(sys$setast(1));
3622                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3623             }
3624
3625             if (info->in->buf) {
3626                 n = info->in->bufsize * sizeof(char);
3627                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3628             }
3629             n = sizeof(Pipe);
3630             _ckvmssts(lib$free_vm(&n, &info->in));
3631             n = sizeof(Info);
3632             _ckvmssts(lib$free_vm(&n, &info));
3633             *psts = RMS$_FNF;
3634             return Nullfp;
3635         }
3636
3637
3638     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3639         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3640         if (info->out) {
3641             info->out->pipe_done = &info->out_done;
3642             info->out_done = FALSE;
3643             info->out->info = info;
3644         }
3645
3646         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3647         if (info->err) {
3648             info->err->pipe_done = &info->err_done;
3649             info->err_done = FALSE;
3650             info->err->info = info;
3651         }
3652     }
3653
3654     symbol[MAX_DCL_SYMBOL] = '\0';
3655
3656     strncpy(symbol, in, MAX_DCL_SYMBOL);
3657     d_symbol.dsc$w_length = strlen(symbol);
3658     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3659
3660     strncpy(symbol, err, MAX_DCL_SYMBOL);
3661     d_symbol.dsc$w_length = strlen(symbol);
3662     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3663
3664     strncpy(symbol, out, MAX_DCL_SYMBOL);
3665     d_symbol.dsc$w_length = strlen(symbol);
3666     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3667
3668     p = vmscmd->dsc$a_pointer;
3669     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
3670     if (*p == '$') p++;                         /* remove leading $ */
3671     while (*p == ' ' || *p == '\t') p++;
3672
3673     for (j = 0; j < 4; j++) {
3674         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3675         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3676
3677     strncpy(symbol, p, MAX_DCL_SYMBOL);
3678     d_symbol.dsc$w_length = strlen(symbol);
3679     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3680
3681         if (strlen(p) > MAX_DCL_SYMBOL) {
3682             p += MAX_DCL_SYMBOL;
3683         } else {
3684             p += strlen(p);
3685         }
3686     }
3687     _ckvmssts(sys$setast(0));
3688     info->next=open_pipes;  /* prepend to list */
3689     open_pipes=info;
3690     _ckvmssts(sys$setast(1));
3691     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3692      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
3693      * have SYS$COMMAND if we need it.
3694      */
3695     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3696                       0, &info->pid, &info->completion,
3697                       0, popen_completion_ast,info,0,0,0));
3698
3699     /* if we were using a tempfile, close it now */
3700
3701     if (tpipe) fclose(tpipe);
3702
3703     /* once the subprocess is spawned, it has copied the symbols and
3704        we can get rid of ours */
3705
3706     for (j = 0; j < 4; j++) {
3707         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3708         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3709     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3710     }
3711     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
3712     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3713     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3714     vms_execfree(vmscmd);
3715
3716 #ifdef PERL_IMPLICIT_CONTEXT
3717     if (aTHX)
3718 #endif
3719     PL_forkprocess = info->pid;
3720
3721     if (wait) {
3722          int done = 0;
3723          while (!done) {
3724              _ckvmssts(sys$setast(0));
3725              done = info->done;
3726              if (!done) _ckvmssts(sys$clref(pipe_ef));
3727              _ckvmssts(sys$setast(1));
3728              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3729          }
3730         *psts = info->completion;
3731 /* Caller thinks it is open and tries to close it. */
3732 /* This causes some problems, as it changes the error status */
3733 /*        my_pclose(info->fp); */
3734     } else {
3735         *psts = SS$_NORMAL;
3736     }
3737     return info->fp;
3738 }  /* end of safe_popen */
3739
3740
3741 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
3742 PerlIO *
3743 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3744 {
3745     int sts;
3746     TAINT_ENV();
3747     TAINT_PROPER("popen");
3748     PERL_FLUSHALL_FOR_CHILD;
3749     return safe_popen(aTHX_ cmd,mode,&sts);
3750 }
3751
3752 /*}}}*/
3753
3754 /*{{{  I32 my_pclose(PerlIO *fp)*/
3755 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3756 {
3757     pInfo info, last = NULL;
3758     unsigned long int retsts;
3759     int done, iss, n;
3760
3761     for (info = open_pipes; info != NULL; last = info, info = info->next)
3762         if (info->fp == fp) break;
3763
3764     if (info == NULL) {  /* no such pipe open */
3765       set_errno(ECHILD); /* quoth POSIX */
3766       set_vaxc_errno(SS$_NONEXPR);
3767       return -1;
3768     }
3769
3770     /* If we were writing to a subprocess, insure that someone reading from
3771      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
3772      * produce an EOF record in the mailbox.
3773      *
3774      *  well, at least sometimes it *does*, so we have to watch out for
3775      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
3776      */
3777      if (info->fp) {
3778         if (!info->useFILE)
3779             PerlIO_flush(info->fp);   /* first, flush data */
3780         else
3781             fflush((FILE *)info->fp);
3782     }
3783
3784     _ckvmssts(sys$setast(0));
3785      info->closing = TRUE;
3786      done = info->done && info->in_done && info->out_done && info->err_done;
3787      /* hanging on write to Perl's input? cancel it */
3788      if (info->mode == 'r' && info->out && !info->out_done) {
3789         if (info->out->chan_out) {
3790             _ckvmssts(sys$cancel(info->out->chan_out));
3791             if (!info->out->chan_in) {   /* EOF generation, need AST */
3792                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3793             }
3794         }
3795      }
3796      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
3797          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3798                            0, 0, 0, 0, 0, 0));
3799     _ckvmssts(sys$setast(1));
3800     if (info->fp) {
3801      if (!info->useFILE)
3802         PerlIO_close(info->fp);
3803      else
3804         fclose((FILE *)info->fp);
3805     }
3806      /*
3807         we have to wait until subprocess completes, but ALSO wait until all
3808         the i/o completes...otherwise we'll be freeing the "info" structure
3809         that the i/o ASTs could still be using...
3810      */
3811
3812      while (!done) {
3813          _ckvmssts(sys$setast(0));
3814          done = info->done && info->in_done && info->out_done && info->err_done;
3815          if (!done) _ckvmssts(sys$clref(pipe_ef));
3816          _ckvmssts(sys$setast(1));
3817          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3818      }
3819      retsts = info->completion;
3820
3821     /* remove from list of open pipes */
3822     _ckvmssts(sys$setast(0));
3823     if (last) last->next = info->next;
3824     else open_pipes = info->next;
3825     _ckvmssts(sys$setast(1));
3826
3827     /* free buffers and structures */
3828
3829     if (info->in) {
3830         if (info->in->buf) {
3831             n = info->in->bufsize * sizeof(char);
3832             _ckvmssts(lib$free_vm(&n, &info->in->buf));
3833         }
3834         n = sizeof(Pipe);
3835         _ckvmssts(lib$free_vm(&n, &info->in));
3836     }
3837     if (info->out) {
3838         if (info->out->buf) {
3839             n = info->out->bufsize * sizeof(char);
3840             _ckvmssts(lib$free_vm(&n, &info->out->buf));
3841         }
3842         n = sizeof(Pipe);
3843         _ckvmssts(lib$free_vm(&n, &info->out));
3844     }
3845     if (info->err) {
3846         if (info->err->buf) {
3847             n = info->err->bufsize * sizeof(char);
3848             _ckvmssts(lib$free_vm(&n, &info->err->buf));
3849         }
3850         n = sizeof(Pipe);
3851         _ckvmssts(lib$free_vm(&n, &info->err));
3852     }
3853     n = sizeof(Info);
3854     _ckvmssts(lib$free_vm(&n, &info));
3855
3856     return retsts;
3857
3858 }  /* end of my_pclose() */
3859
3860 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3861   /* Roll our own prototype because we want this regardless of whether
3862    * _VMS_WAIT is defined.
3863    */
3864   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3865 #endif
3866 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3867    created with popen(); otherwise partially emulate waitpid() unless
3868    we have a suitable one from the CRTL that came with VMS 7.2 and later.
3869    Also check processes not considered by the CRTL waitpid().
3870  */
3871 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3872 Pid_t
3873 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3874 {
3875     pInfo info;
3876     int done;
3877     int sts;
3878     int j;
3879
3880     if (statusp) *statusp = 0;
3881
3882     for (info = open_pipes; info != NULL; info = info->next)
3883         if (info->pid == pid) break;
3884
3885     if (info != NULL) {  /* we know about this child */
3886       while (!info->done) {
3887           _ckvmssts(sys$setast(0));
3888           done = info->done;
3889           if (!done) _ckvmssts(sys$clref(pipe_ef));
3890           _ckvmssts(sys$setast(1));
3891           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3892       }
3893
3894       if (statusp) *statusp = info->completion;
3895       return pid;
3896     }
3897
3898     /* child that already terminated? */
3899
3900     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3901         if (closed_list[j].pid == pid) {
3902             if (statusp) *statusp = closed_list[j].completion;
3903             return pid;
3904         }
3905     }
3906
3907     /* fall through if this child is not one of our own pipe children */
3908
3909 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3910
3911       /* waitpid() became available in the CRTL as of VMS 7.0, but only
3912        * in 7.2 did we get a version that fills in the VMS completion
3913        * status as Perl has always tried to do.
3914        */
3915
3916       sts = __vms_waitpid( pid, statusp, flags );
3917
3918       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3919          return sts;
3920
3921       /* If the real waitpid tells us the child does not exist, we
3922        * fall through here to implement waiting for a child that
3923        * was created by some means other than exec() (say, spawned
3924        * from DCL) or to wait for a process that is not a subprocess
3925        * of the current process.
3926        */
3927
3928 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3929
3930     {
3931       $DESCRIPTOR(intdsc,"0 00:00:01");
3932       unsigned long int ownercode = JPI$_OWNER, ownerpid;
3933       unsigned long int pidcode = JPI$_PID, mypid;
3934       unsigned long int interval[2];
3935       unsigned int jpi_iosb[2];
3936       struct itmlst_3 jpilist[2] = {
3937           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
3938           {                      0,         0,                 0, 0}
3939       };
3940
3941       if (pid <= 0) {
3942         /* Sorry folks, we don't presently implement rooting around for
3943            the first child we can find, and we definitely don't want to
3944            pass a pid of -1 to $getjpi, where it is a wildcard operation.
3945          */
3946         set_errno(ENOTSUP);
3947         return -1;
3948       }
3949
3950       /* Get the owner of the child so I can warn if it's not mine. If the
3951        * process doesn't exist or I don't have the privs to look at it,
3952        * I can go home early.
3953        */
3954       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3955       if (sts & 1) sts = jpi_iosb[0];
3956       if (!(sts & 1)) {
3957         switch (sts) {
3958             case SS$_NONEXPR:
3959                 set_errno(ECHILD);
3960                 break;
3961             case SS$_NOPRIV:
3962                 set_errno(EACCES);
3963                 break;
3964             default:
3965                 _ckvmssts(sts);
3966         }
3967         set_vaxc_errno(sts);
3968         return -1;
3969       }
3970
3971       if (ckWARN(WARN_EXEC)) {
3972         /* remind folks they are asking for non-standard waitpid behavior */
3973         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3974         if (ownerpid != mypid)
3975           Perl_warner(aTHX_ packWARN(WARN_EXEC),
3976                       "waitpid: process %x is not a child of process %x",
3977                       pid,mypid);
3978       }
3979
3980       /* simply check on it once a second until it's not there anymore. */
3981
3982       _ckvmssts(sys$bintim(&intdsc,interval));
3983       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3984             _ckvmssts(sys$schdwk(0,0,interval,0));
3985             _ckvmssts(sys$hiber());
3986       }
3987       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3988
3989       _ckvmssts(sts);
3990       return pid;
3991     }
3992 }  /* end of waitpid() */
3993 /*}}}*/
3994 /*}}}*/
3995 /*}}}*/
3996
3997 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3998 char *
3999 my_gconvert(double val, int ndig, int trail, char *buf)
4000 {
4001   static char __gcvtbuf[DBL_DIG+1];
4002   char *loc;
4003
4004   loc = buf ? buf : __gcvtbuf;
4005
4006 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4007   if (val < 1) {
4008     sprintf(loc,"%.*g",ndig,val);
4009     return loc;
4010   }
4011 #endif
4012
4013   if (val) {
4014     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4015     return gcvt(val,ndig,loc);
4016   }
4017   else {
4018     loc[0] = '0'; loc[1] = '\0';
4019     return loc;
4020   }
4021
4022 }
4023 /*}}}*/
4024
4025 #if 1 /* defined(__VAX) || !defined(NAML$C_MAXRSS) */
4026 static int rms_free_search_context(struct FAB * fab)
4027 {
4028 struct NAM * nam;
4029
4030     nam = fab->fab$l_nam;
4031     nam->nam$b_nop |= NAM$M_SYNCHK;
4032     nam->nam$l_rlf = NULL;
4033     fab->fab$b_dns = 0;
4034     return sys$parse(fab, NULL, NULL);
4035 }
4036
4037 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4038 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4039 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4040 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4041 #define rms_nam_esll(nam) nam.nam$b_esl
4042 #define rms_nam_esl(nam) nam.nam$b_esl
4043 #define rms_nam_name(nam) nam.nam$l_name
4044 #define rms_nam_namel(nam) nam.nam$l_name
4045 #define rms_nam_type(nam) nam.nam$l_type
4046 #define rms_nam_typel(nam) nam.nam$l_type
4047 #define rms_nam_ver(nam) nam.nam$l_ver
4048 #define rms_nam_verl(nam) nam.nam$l_ver
4049 #define rms_nam_rsll(nam) nam.nam$b_rsl
4050 #define rms_nam_rsl(nam) nam.nam$b_rsl
4051 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4052 #define rms_set_fna(fab, nam, name, size) \
4053         fab.fab$b_fns = size; fab.fab$l_fna = name;
4054 #define rms_get_fna(fab, nam) fab.fab$l_fna
4055 #define rms_set_dna(fab, nam, name, size) \
4056         fab.fab$b_dns = size; fab.fab$l_dna = name;
4057 #define rms_nam_dns(fab, nam) fab.fab$b_dns;
4058 #define rms_set_esa(fab, nam, name, size) \
4059         nam.nam$b_ess = size; nam.nam$l_esa = name;
4060 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4061         nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
4062 #define rms_set_rsa(nam, name, size) \
4063         nam.nam$l_rsa = name; nam.nam$b_rss = size;
4064 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4065         nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
4066
4067 #else
4068 static int rms_free_search_context(struct FAB * fab)
4069 {
4070 struct NAML * nam;
4071
4072     nam = fab->fab$l_naml;
4073     nam->naml$b_nop |= NAM$M_SYNCHK;
4074     nam->naml$l_rlf = NULL;
4075     nam->naml$l_long_defname_size = 0;
4076     fab->fab$b_dns = 0;
4077     return sys$parse(fab, NULL, NULL);
4078 }
4079
4080 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4081 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4082 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4083 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4084 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4085 #define rms_nam_esl(nam) nam.naml$b_esl
4086 #define rms_nam_name(nam) nam.naml$l_name
4087 #define rms_nam_namel(nam) nam.naml$l_long_name
4088 #define rms_nam_type(nam) nam.naml$l_type
4089 #define rms_nam_typel(nam) nam.naml$l_long_type
4090 #define rms_nam_ver(nam) nam.naml$l_ver
4091 #define rms_nam_verl(nam) nam.naml$l_long_ver
4092 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4093 #define rms_nam_rsl(nam) nam.naml$b_rsl
4094 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4095 #define rms_set_fna(fab, nam, name, size) \
4096         fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4097         nam.naml$l_long_filename_size = size; \
4098         nam.naml$l_long_filename = name
4099 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4100 #define rms_set_dna(fab, nam, name, size) \
4101         fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4102         nam.naml$l_long_defname_size = size; \
4103         nam.naml$l_long_defname = name
4104 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4105 #define rms_set_esa(fab, nam, name, size) \
4106         nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4107         nam.naml$l_long_expand_alloc = size; \
4108         nam.naml$l_long_expand = name
4109 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4110         nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4111         nam.naml$l_long_expand = l_name; \
4112         nam.naml$l_long_expand_alloc = l_size;
4113 #define rms_set_rsa(nam, name, size) \
4114         nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4115         nam.naml$l_long_result = name; \
4116         nam.naml$l_long_result_alloc = size;
4117 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4118         nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4119         nam.naml$l_long_result = l_name; \
4120         nam.naml$l_long_result_alloc = l_size;
4121
4122 #endif
4123
4124
4125 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4126 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4127  * to expand file specification.  Allows for a single default file
4128  * specification and a simple mask of options.  If outbuf is non-NULL,
4129  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4130  * the resultant file specification is placed.  If outbuf is NULL, the
4131  * resultant file specification is placed into a static buffer.
4132  * The third argument, if non-NULL, is taken to be a default file
4133  * specification string.  The fourth argument is unused at present.
4134  * rmesexpand() returns the address of the resultant string if
4135  * successful, and NULL on error.
4136  *
4137  * New functionality for previously unused opts value:
4138  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4139  */
4140 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
4141
4142 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4143 /* ODS-2 only version */
4144 static char *
4145 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4146 {
4147   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
4148   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
4149   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
4150   struct FAB myfab = cc$rms_fab;
4151   struct NAM mynam = cc$rms_nam;
4152   STRLEN speclen;
4153   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4154   int sts;
4155
4156   if (!filespec || !*filespec) {
4157     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4158     return NULL;
4159   }
4160   if (!outbuf) {
4161     if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
4162     else    outbuf = __rmsexpand_retbuf;
4163   }
4164   isunix = is_unix_filespec(filespec);
4165   if (isunix) {
4166     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4167         if (out)
4168            Safefree(out);
4169         return NULL;
4170     }
4171     filespec = vmsfspec;
4172   }
4173
4174   myfab.fab$l_fna = (char *)filespec;  /* cast ok for read only pointer */
4175   myfab.fab$b_fns = strlen(filespec);
4176   myfab.fab$l_nam = &mynam;
4177
4178   if (defspec && *defspec) {
4179     if (strchr(defspec,'/') != NULL) {
4180       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4181         if (out)
4182            Safefree(out);
4183         return NULL;
4184       }
4185       defspec = tmpfspec;
4186     }
4187     myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
4188     myfab.fab$b_dns = strlen(defspec);
4189   }
4190
4191   mynam.nam$l_esa = esa;
4192   mynam.nam$b_ess = sizeof esa;
4193   mynam.nam$l_rsa = outbuf;
4194   mynam.nam$b_rss = NAM$C_MAXRSS;
4195
4196 #ifdef NAM$M_NO_SHORT_UPCASE
4197   if (decc_efs_case_preserve)
4198     mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4199 #endif
4200
4201   retsts = sys$parse(&myfab,0,0);
4202   if (!(retsts & 1)) {
4203     mynam.nam$b_nop |= NAM$M_SYNCHK;
4204     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4205       retsts = sys$parse(&myfab,0,0);
4206       if (retsts & 1) goto expanded;
4207     }
4208     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
4209     sts = sys$parse(&myfab,0,0);  /* Free search context */
4210     if (out) Safefree(out);
4211     set_vaxc_errno(retsts);
4212     if      (retsts == RMS$_PRV) set_errno(EACCES);
4213     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4214     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4215     else                         set_errno(EVMSERR);
4216     return NULL;
4217   }
4218   retsts = sys$search(&myfab,0,0);
4219   if (!(retsts & 1) && retsts != RMS$_FNF) {
4220     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4221     myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
4222     if (out) Safefree(out);
4223     set_vaxc_errno(retsts);
4224     if      (retsts == RMS$_PRV) set_errno(EACCES);
4225     else                         set_errno(EVMSERR);
4226     return NULL;
4227   }
4228
4229   /* If the input filespec contained any lowercase characters,
4230    * downcase the result for compatibility with Unix-minded code. */
4231   expanded:
4232   if (!decc_efs_case_preserve) {
4233     for (out = myfab.fab$l_fna; *out; out++)
4234       if (islower(*out)) { haslower = 1; break; }
4235   }
4236   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
4237   else                 { out = esa;    speclen = mynam.nam$b_esl; }
4238   /* Trim off null fields added by $PARSE
4239    * If type > 1 char, must have been specified in original or default spec
4240    * (not true for version; $SEARCH may have added version of existing file).
4241    */
4242   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
4243   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
4244              (mynam.nam$l_ver - mynam.nam$l_type == 1);
4245   if (trimver || trimtype) {
4246     if (defspec && *defspec) {
4247       char defesa[NAM$C_MAXRSS];
4248       struct FAB deffab = cc$rms_fab;
4249       struct NAM defnam = cc$rms_nam;
4250
4251       deffab.fab$l_nam = &defnam;
4252       /* cast below ok for read only pointer */
4253       deffab.fab$l_fna = (char *)defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
4254       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
4255       defnam.nam$b_nop = NAM$M_SYNCHK;
4256 #ifdef NAM$M_NO_SHORT_UPCASE
4257       if (decc_efs_case_preserve)
4258         defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4259 #endif
4260       if (sys$parse(&deffab,0,0) & 1) {
4261         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
4262         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4263       }
4264     }
4265     if (trimver) {
4266       if (*mynam.nam$l_ver != '\"')
4267         speclen = mynam.nam$l_ver - out;
4268     }
4269     if (trimtype) {
4270       /* If we didn't already trim version, copy down */
4271       if (speclen > mynam.nam$l_ver - out)
4272         memmove(mynam.nam$l_type, mynam.nam$l_ver,
4273                speclen - (mynam.nam$l_ver - out));
4274       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4275     }
4276   }
4277   /* If we just had a directory spec on input, $PARSE "helpfully"
4278    * adds an empty name and type for us */
4279   if (mynam.nam$l_name == mynam.nam$l_type &&
4280       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
4281       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4282     speclen = mynam.nam$l_name - out;
4283
4284   /* Posix format specifications must have matching quotes */
4285   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4286     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4287       out[speclen] = '\"';
4288       speclen++;
4289     }
4290   }
4291
4292   out[speclen] = '\0';
4293   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4294
4295   /* Have we been working with an expanded, but not resultant, spec? */
4296   /* Also, convert back to Unix syntax if necessary. */
4297   if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4298     isunix = 0;
4299
4300   if (!mynam.nam$b_rsl) {
4301     if (isunix) {
4302       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4303     }
4304     else strcpy(outbuf,esa);
4305   }
4306   else if (isunix) {
4307     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4308     strcpy(outbuf,tmpfspec);
4309   }
4310   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4311   mynam.nam$l_rsa = NULL;
4312   mynam.nam$b_rss = 0;
4313   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);  /* Free search context */
4314   return outbuf;
4315 }
4316 #else
4317 /* ODS-5 supporting routine */
4318 static char *
4319 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4320 {
4321   static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4322   char * vmsfspec, *tmpfspec;
4323   char * esa, *cp, *out = NULL;
4324   char * esal;
4325   char * outbufl;
4326   struct FAB myfab = cc$rms_fab;
4327   rms_setup_nam(mynam);
4328   STRLEN speclen;
4329   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4330   int sts;
4331
4332   if (!filespec || !*filespec) {
4333     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4334     return NULL;
4335   }
4336   if (!outbuf) {
4337     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4338     else    outbuf = __rmsexpand_retbuf;
4339   }
4340
4341   vmsfspec = NULL;
4342   tmpfspec = NULL;
4343   outbufl = NULL;
4344   isunix = is_unix_filespec(filespec);
4345   if (isunix) {
4346     Newx(vmsfspec, VMS_MAXRSS, char);
4347     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4348         Safefree(vmsfspec);
4349         if (out)
4350            Safefree(out);
4351         return NULL;
4352     }
4353     filespec = vmsfspec;
4354
4355      /* Unless we are forcing to VMS format, a UNIX input means
4356       * UNIX output, and that requires long names to be used
4357       */
4358     if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4359         opts |= PERL_RMSEXPAND_M_LONG;
4360     else {
4361         isunix = 0;
4362     }
4363   }
4364
4365   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4366   rms_bind_fab_nam(myfab, mynam);
4367
4368   if (defspec && *defspec) {
4369     int t_isunix;
4370     t_isunix = is_unix_filespec(defspec);
4371     if (t_isunix) {
4372       Newx(tmpfspec, VMS_MAXRSS, char);
4373       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4374         Safefree(tmpfspec);
4375         if (vmsfspec != NULL)
4376             Safefree(vmsfspec);
4377         if (out)
4378            Safefree(out);
4379         return NULL;
4380       }
4381       defspec = tmpfspec;
4382     }
4383     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4384   }
4385
4386   Newx(esa, NAM$C_MAXRSS + 1, char);
4387 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4388   Newx(esal, NAML$C_MAXRSS + 1, char);
4389 #endif
4390   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
4391
4392   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4393     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4394   }
4395   else {
4396 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4397     Newx(outbufl, VMS_MAXRSS, char);
4398     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4399 #else
4400     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4401 #endif
4402   }
4403
4404 #ifdef NAM$M_NO_SHORT_UPCASE
4405   if (decc_efs_case_preserve)
4406     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4407 #endif
4408
4409   /* First attempt to parse as an existing file */
4410   retsts = sys$parse(&myfab,0,0);
4411   if (!(retsts & STS$K_SUCCESS)) {
4412
4413     /* Could not find the file, try as syntax only if error is not fatal */
4414     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4415     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4416       retsts = sys$parse(&myfab,0,0);
4417       if (retsts & STS$K_SUCCESS) goto expanded;
4418     }
4419
4420      /* Still could not parse the file specification */
4421     /*----------------------------------------------*/
4422     sts = rms_free_search_context(&myfab); /* Free search context */
4423     if (out) Safefree(out);
4424     if (tmpfspec != NULL)
4425         Safefree(tmpfspec);
4426     if (vmsfspec != NULL)
4427         Safefree(vmsfspec);
4428     Safefree(esa);
4429     Safefree(esal);
4430     set_vaxc_errno(retsts);
4431     if      (retsts == RMS$_PRV) set_errno(EACCES);
4432     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4433     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4434     else                         set_errno(EVMSERR);
4435     return NULL;
4436   }
4437   retsts = sys$search(&myfab,0,0);
4438   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4439     sts = rms_free_search_context(&myfab); /* Free search context */
4440     if (out) Safefree(out);
4441     if (tmpfspec != NULL)
4442         Safefree(tmpfspec);
4443     if (vmsfspec != NULL)
4444         Safefree(vmsfspec);
4445     Safefree(esa);
4446     Safefree(esal);
4447     set_vaxc_errno(retsts);
4448     if      (retsts == RMS$_PRV) set_errno(EACCES);
4449     else                         set_errno(EVMSERR);
4450     return NULL;
4451   }
4452
4453   /* If the input filespec contained any lowercase characters,
4454    * downcase the result for compatibility with Unix-minded code. */
4455   expanded:
4456   if (!decc_efs_case_preserve) {
4457     for (out = rms_get_fna(myfab, mynam); *out; out++)
4458       if (islower(*out)) { haslower = 1; break; }
4459   }
4460
4461    /* Is a long or a short name expected */
4462   /*------------------------------------*/
4463   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4464     if (rms_nam_rsll(mynam)) {
4465         out = outbuf;
4466         speclen = rms_nam_rsll(mynam);
4467     }
4468     else {
4469         out = esal; /* Not esa */
4470         speclen = rms_nam_esll(mynam);
4471     }
4472   }
4473   else {
4474     if (rms_nam_rsl(mynam)) {
4475         out = outbuf;
4476         speclen = rms_nam_rsl(mynam);
4477     }
4478     else {
4479         out = esa; /* Not esal */
4480         speclen = rms_nam_esl(mynam);
4481     }
4482   }
4483   /* Trim off null fields added by $PARSE
4484    * If type > 1 char, must have been specified in original or default spec
4485    * (not true for version; $SEARCH may have added version of existing file).
4486    */
4487   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4488   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4489     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4490              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4491   }
4492   else {
4493     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4494              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4495   }
4496   if (trimver || trimtype) {
4497     if (defspec && *defspec) {
4498       char *defesal = NULL;
4499       Newx(defesal, NAML$C_MAXRSS + 1, char);
4500       if (defesal != NULL) {
4501         struct FAB deffab = cc$rms_fab;
4502         rms_setup_nam(defnam);
4503
4504         rms_bind_fab_nam(deffab, defnam);
4505
4506         /* Cast ok */
4507         rms_set_fna
4508             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4509
4510         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4511
4512         rms_set_nam_nop(defnam, 0);
4513         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4514 #ifdef NAM$M_NO_SHORT_UPCASE
4515         if (decc_efs_case_preserve)
4516           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4517 #endif
4518         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4519           if (trimver) {
4520              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4521           }
4522           if (trimtype) {
4523             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4524           }
4525         }
4526         Safefree(defesal);
4527       }
4528     }
4529     if (trimver) {
4530       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4531         if (*(rms_nam_verl(mynam)) != '\"')
4532           speclen = rms_nam_verl(mynam) - out;
4533       }
4534       else {
4535         if (*(rms_nam_ver(mynam)) != '\"')
4536           speclen = rms_nam_ver(mynam) - out;
4537       }
4538     }
4539     if (trimtype) {
4540       /* If we didn't already trim version, copy down */
4541       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4542         if (speclen > rms_nam_verl(mynam) - out)
4543           memmove
4544            (rms_nam_typel(mynam),
4545             rms_nam_verl(mynam),
4546             speclen - (rms_nam_verl(mynam) - out));
4547           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4548       }
4549       else {
4550         if (speclen > rms_nam_ver(mynam) - out)
4551           memmove
4552            (rms_nam_type(mynam),
4553             rms_nam_ver(mynam),
4554             speclen - (rms_nam_ver(mynam) - out));
4555           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4556       }
4557     }
4558   }
4559
4560    /* Done with these copies of the input files */
4561   /*-------------------------------------------*/
4562   if (vmsfspec != NULL)
4563         Safefree(vmsfspec);
4564   if (tmpfspec != NULL)
4565         Safefree(tmpfspec);
4566
4567   /* If we just had a directory spec on input, $PARSE "helpfully"
4568    * adds an empty name and type for us */
4569   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4570     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4571         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
4572         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4573       speclen = rms_nam_namel(mynam) - out;
4574   }
4575   else {
4576     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4577         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
4578         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4579       speclen = rms_nam_name(mynam) - out;
4580   }
4581
4582   /* Posix format specifications must have matching quotes */
4583   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4584     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4585       out[speclen] = '\"';
4586       speclen++;
4587     }
4588   }
4589   out[speclen] = '\0';
4590   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4591
4592   /* Have we been working with an expanded, but not resultant, spec? */
4593   /* Also, convert back to Unix syntax if necessary. */
4594
4595   if (!rms_nam_rsll(mynam)) {
4596     if (isunix) {
4597       if (do_tounixspec(esa,outbuf,0) == NULL) {
4598         Safefree(esal);
4599         Safefree(esa);
4600         return NULL;
4601       }
4602     }
4603     else strcpy(outbuf,esa);
4604   }
4605   else if (isunix) {
4606     Newx(tmpfspec, VMS_MAXRSS, char);
4607     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4608         Safefree(esa);
4609         Safefree(esal);
4610         Safefree(tmpfspec);
4611         return NULL;
4612     }
4613     strcpy(outbuf,tmpfspec);
4614     Safefree(tmpfspec);
4615   }
4616
4617   rms_set_rsal(mynam, NULL, 0, NULL, 0);
4618   sts = rms_free_search_context(&myfab); /* Free search context */
4619   Safefree(esa);
4620   Safefree(esal);
4621   return outbuf;
4622 }
4623 #endif
4624 /*}}}*/
4625 /* External entry points */
4626 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4627 { return do_rmsexpand(spec,buf,0,def,opt); }
4628 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4629 { return do_rmsexpand(spec,buf,1,def,opt); }
4630
4631
4632 /*
4633 ** The following routines are provided to make life easier when
4634 ** converting among VMS-style and Unix-style directory specifications.
4635 ** All will take input specifications in either VMS or Unix syntax. On
4636 ** failure, all return NULL.  If successful, the routines listed below
4637 ** return a pointer to a buffer containing the appropriately
4638 ** reformatted spec (and, therefore, subsequent calls to that routine
4639 ** will clobber the result), while the routines of the same names with
4640 ** a _ts suffix appended will return a pointer to a mallocd string
4641 ** containing the appropriately reformatted spec.
4642 ** In all cases, only explicit syntax is altered; no check is made that
4643 ** the resulting string is valid or that the directory in question
4644 ** actually exists.
4645 **
4646 **   fileify_dirspec() - convert a directory spec into the name of the
4647 **     directory file (i.e. what you can stat() to see if it's a dir).
4648 **     The style (VMS or Unix) of the result is the same as the style
4649 **     of the parameter passed in.
4650 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4651 **     what you prepend to a filename to indicate what directory it's in).
4652 **     The style (VMS or Unix) of the result is the same as the style
4653 **     of the parameter passed in.
4654 **   tounixpath() - convert a directory spec into a Unix-style path.
4655 **   tovmspath() - convert a directory spec into a VMS-style path.
4656 **   tounixspec() - convert any file spec into a Unix-style file spec.
4657 **   tovmsspec() - convert any file spec into a VMS-style spec.
4658 **
4659 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4660 ** Permission is given to distribute this code as part of the Perl
4661 ** standard distribution under the terms of the GNU General Public
4662 ** License or the Perl Artistic License.  Copies of each may be
4663 ** found in the Perl standard distribution.
4664  */
4665
4666 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4667 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4668 {
4669     static char __fileify_retbuf[VMS_MAXRSS];
4670     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4671     char *retspec, *cp1, *cp2, *lastdir;
4672     char *trndir, *vmsdir;
4673     unsigned short int trnlnm_iter_count;
4674     int sts;
4675
4676     if (!dir || !*dir) {
4677       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4678     }
4679     dirlen = strlen(dir);
4680     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4681     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4682       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4683         dir = "/sys$disk";
4684         dirlen = 9;
4685       }
4686       else
4687         dirlen = 1;
4688     }
4689     if (dirlen > (VMS_MAXRSS - 1)) {
4690       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4691       return NULL;
4692     }
4693     Newx(trndir, VMS_MAXRSS + 1, char);
4694     if (!strpbrk(dir+1,"/]>:")  &&
4695         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4696       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4697       trnlnm_iter_count = 0;
4698       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4699         trnlnm_iter_count++;
4700         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4701       }
4702       dirlen = strlen(trndir);
4703     }
4704     else {
4705       strncpy(trndir,dir,dirlen);
4706       trndir[dirlen] = '\0';
4707     }
4708
4709     /* At this point we are done with *dir and use *trndir which is a
4710      * copy that can be modified.  *dir must not be modified.
4711      */
4712
4713     /* If we were handed a rooted logical name or spec, treat it like a
4714      * simple directory, so that
4715      *    $ Define myroot dev:[dir.]
4716      *    ... do_fileify_dirspec("myroot",buf,1) ...
4717      * does something useful.
4718      */
4719     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4720       trndir[--dirlen] = '\0';
4721       trndir[dirlen-1] = ']';
4722     }
4723     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4724       trndir[--dirlen] = '\0';
4725       trndir[dirlen-1] = '>';
4726     }
4727
4728     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4729       /* If we've got an explicit filename, we can just shuffle the string. */
4730       if (*(cp1+1)) hasfilename = 1;
4731       /* Similarly, we can just back up a level if we've got multiple levels
4732          of explicit directories in a VMS spec which ends with directories. */
4733       else {
4734         for (cp2 = cp1; cp2 > trndir; cp2--) {
4735           if (*cp2 == '.') {
4736             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4737 /* fix-me, can not scan EFS file specs backward like this */
4738               *cp2 = *cp1; *cp1 = '\0';
4739               hasfilename = 1;
4740               break;
4741             }
4742           }
4743           if (*cp2 == '[' || *cp2 == '<') break;
4744         }
4745       }
4746     }
4747
4748     Newx(vmsdir, VMS_MAXRSS + 1, char);
4749     cp1 = strpbrk(trndir,"]:>");
4750     if (hasfilename || !cp1) { /* Unix-style path or filename */
4751       if (trndir[0] == '.') {
4752         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4753           Safefree(trndir);
4754           Safefree(vmsdir);
4755           return do_fileify_dirspec("[]",buf,ts);
4756         }
4757         else if (trndir[1] == '.' &&
4758                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4759           Safefree(trndir);
4760           Safefree(vmsdir);
4761           return do_fileify_dirspec("[-]",buf,ts);
4762         }
4763       }
4764       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4765         dirlen -= 1;                 /* to last element */
4766         lastdir = strrchr(trndir,'/');
4767       }
4768       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4769         /* If we have "/." or "/..", VMSify it and let the VMS code
4770          * below expand it, rather than repeating the code to handle
4771          * relative components of a filespec here */
4772         do {
4773           if (*(cp1+2) == '.') cp1++;
4774           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4775             char * ret_chr;
4776             if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4777                 Safefree(trndir);
4778                 Safefree(vmsdir);
4779                 return NULL;
4780             }
4781             if (strchr(vmsdir,'/') != NULL) {
4782               /* If do_tovmsspec() returned it, it must have VMS syntax
4783                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
4784                * the time to check this here only so we avoid a recursion
4785                * loop; otherwise, gigo.
4786                */
4787               Safefree(trndir);
4788               Safefree(vmsdir);
4789               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
4790               return NULL;
4791             }
4792             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4793                 Safefree(trndir);
4794                 Safefree(vmsdir);
4795                 return NULL;
4796             }
4797             ret_chr = do_tounixspec(trndir,buf,ts);
4798             Safefree(trndir);
4799             Safefree(vmsdir);
4800             return ret_chr;
4801           }
4802           cp1++;
4803         } while ((cp1 = strstr(cp1,"/.")) != NULL);
4804         lastdir = strrchr(trndir,'/');
4805       }
4806       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4807         char * ret_chr;
4808         /* Ditto for specs that end in an MFD -- let the VMS code
4809          * figure out whether it's a real device or a rooted logical. */
4810
4811         /* This should not happen any more.  Allowing the fake /000000
4812          * in a UNIX pathname causes all sorts of problems when trying
4813          * to run in UNIX emulation.  So the VMS to UNIX conversions
4814          * now remove the fake /000000 directories.
4815          */
4816
4817         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4818         if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4819             Safefree(trndir);
4820             Safefree(vmsdir);
4821             return NULL;
4822         }
4823         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4824             Safefree(trndir);
4825             Safefree(vmsdir);
4826             return NULL;
4827         }
4828         ret_chr = do_tounixspec(trndir,buf,ts);
4829         Safefree(trndir);
4830         Safefree(vmsdir);
4831         return ret_chr;
4832       }
4833       else {
4834
4835         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4836              !(lastdir = cp1 = strrchr(trndir,']')) &&
4837              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4838         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
4839           int ver; char *cp3;
4840
4841           /* For EFS or ODS-5 look for the last dot */
4842           if (decc_efs_charset) {
4843               cp2 = strrchr(cp1,'.');
4844           }
4845           if (vms_process_case_tolerant) {
4846               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4847                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4848                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4849                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4850                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4851                             (ver || *cp3)))))) {
4852                   Safefree(trndir);
4853                   Safefree(vmsdir);
4854                   set_errno(ENOTDIR);
4855                   set_vaxc_errno(RMS$_DIR);
4856                   return NULL;
4857               }
4858           }
4859           else {
4860               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4861                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4862                   !*(cp2+3) || *(cp2+3) != 'R' ||
4863                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4864                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4865                             (ver || *cp3)))))) {
4866                  Safefree(trndir);
4867                  Safefree(vmsdir);
4868                  set_errno(ENOTDIR);
4869                  set_vaxc_errno(RMS$_DIR);
4870                  return NULL;
4871               }
4872           }
4873           dirlen = cp2 - trndir;
4874         }
4875       }
4876
4877       retlen = dirlen + 6;
4878       if (buf) retspec = buf;
4879       else if (ts) Newx(retspec,retlen+1,char);
4880       else retspec = __fileify_retbuf;
4881       memcpy(retspec,trndir,dirlen);
4882       retspec[dirlen] = '\0';
4883
4884       /* We've picked up everything up to the directory file name.
4885          Now just add the type and version, and we're set. */
4886       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4887         strcat(retspec,".dir;1");
4888       else
4889         strcat(retspec,".DIR;1");
4890       Safefree(trndir);
4891       Safefree(vmsdir);
4892       return retspec;
4893     }
4894     else {  /* VMS-style directory spec */
4895
4896       char *esa, term, *cp;
4897       unsigned long int sts, cmplen, haslower = 0;
4898       unsigned int nam_fnb;
4899       char * nam_type;
4900       struct FAB dirfab = cc$rms_fab;
4901       rms_setup_nam(savnam);
4902       rms_setup_nam(dirnam);
4903
4904       Newx(esa, VMS_MAXRSS + 1, char);
4905       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4906       rms_bind_fab_nam(dirfab, dirnam);
4907       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4908       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4909 #ifdef NAM$M_NO_SHORT_UPCASE
4910       if (decc_efs_case_preserve)
4911         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4912 #endif
4913
4914       for (cp = trndir; *cp; cp++)
4915         if (islower(*cp)) { haslower = 1; break; }
4916       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4917         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4918           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4919           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4920         }
4921         if (!sts) {
4922           Safefree(esa);
4923           Safefree(trndir);
4924           Safefree(vmsdir);
4925           set_errno(EVMSERR);
4926           set_vaxc_errno(dirfab.fab$l_sts);
4927           return NULL;
4928         }
4929       }
4930       else {
4931         savnam = dirnam;
4932         /* Does the file really exist? */
4933         if (sys$search(&dirfab)& STS$K_SUCCESS) {
4934           /* Yes; fake the fnb bits so we'll check type below */
4935         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4936         }
4937         else { /* No; just work with potential name */
4938           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4939           else {
4940             Safefree(esa);
4941             Safefree(trndir);
4942             Safefree(vmsdir);
4943             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
4944             sts = rms_free_search_context(&dirfab);
4945             return NULL;
4946           }
4947         }
4948       }
4949       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4950         cp1 = strchr(esa,']');
4951         if (!cp1) cp1 = strchr(esa,'>');
4952         if (cp1) {  /* Should always be true */
4953           rms_nam_esll(dirnam) -= cp1 - esa - 1;
4954           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
4955         }
4956       }
4957       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
4958         /* Yep; check version while we're at it, if it's there. */
4959         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
4960         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
4961           /* Something other than .DIR[;1].  Bzzt. */
4962           sts = rms_free_search_context(&dirfab);
4963           Safefree(esa);
4964           Safefree(trndir);
4965           Safefree(vmsdir);
4966           set_errno(ENOTDIR);
4967           set_vaxc_errno(RMS$_DIR);
4968           return NULL;
4969         }
4970       }
4971       esa[rms_nam_esll(dirnam)] = '\0';
4972       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
4973         /* They provided at least the name; we added the type, if necessary, */
4974         if (buf) retspec = buf;                            /* in sys$parse() */
4975         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
4976         else retspec = __fileify_retbuf;
4977         strcpy(retspec,esa);
4978         sts = rms_free_search_context(&dirfab);
4979         Safefree(trndir);
4980         Safefree(esa);
4981         Safefree(vmsdir);
4982         return retspec;
4983       }
4984       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4985         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4986         *cp1 = '\0';
4987         rms_nam_esll(dirnam) -= 9;
4988       }
4989       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4990       if (cp1 == NULL) { /* should never happen */
4991         sts = rms_free_search_context(&dirfab);
4992         Safefree(trndir);
4993         Safefree(esa);
4994         Safefree(vmsdir);
4995         return NULL;
4996       }
4997       term = *cp1;
4998       *cp1 = '\0';
4999       retlen = strlen(esa);
5000       cp1 = strrchr(esa,'.');
5001       /* ODS-5 directory specifications can have extra "." in them. */
5002       /* Fix-me, can not scan EFS file specifications backwards */
5003       while (cp1 != NULL) {
5004         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5005           break;
5006         else {
5007            cp1--;
5008            while ((cp1 > esa) && (*cp1 != '.'))
5009              cp1--;
5010         }
5011         if (cp1 == esa)
5012           cp1 = NULL;
5013       }
5014
5015       if ((cp1) != NULL) {
5016         /* There's more than one directory in the path.  Just roll back. */
5017         *cp1 = term;
5018         if (buf) retspec = buf;
5019         else if (ts) Newx(retspec,retlen+7,char);
5020         else retspec = __fileify_retbuf;
5021         strcpy(retspec,esa);
5022       }
5023       else {
5024         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5025           /* Go back and expand rooted logical name */
5026           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5027 #ifdef NAM$M_NO_SHORT_UPCASE
5028           if (decc_efs_case_preserve)
5029             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5030 #endif
5031           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5032             sts = rms_free_search_context(&dirfab);
5033             Safefree(esa);
5034             Safefree(trndir);
5035             Safefree(vmsdir);
5036             set_errno(EVMSERR);
5037             set_vaxc_errno(dirfab.fab$l_sts);
5038             return NULL;
5039           }
5040           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5041           if (buf) retspec = buf;
5042           else if (ts) Newx(retspec,retlen+16,char);
5043           else retspec = __fileify_retbuf;
5044           cp1 = strstr(esa,"][");
5045           if (!cp1) cp1 = strstr(esa,"]<");
5046           dirlen = cp1 - esa;
5047           memcpy(retspec,esa,dirlen);
5048           if (!strncmp(cp1+2,"000000]",7)) {
5049             retspec[dirlen-1] = '\0';
5050             /* fix-me Not full ODS-5, just extra dots in directories for now */
5051             cp1 = retspec + dirlen - 1;
5052             while (cp1 > retspec)
5053             {
5054               if (*cp1 == '[')
5055                 break;
5056               if (*cp1 == '.') {
5057                 if (*(cp1-1) != '^')
5058                   break;
5059               }
5060               cp1--;
5061             }
5062             if (*cp1 == '.') *cp1 = ']';
5063             else {
5064               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5065               memmove(cp1+1,"000000]",7);
5066             }
5067           }
5068           else {
5069             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5070             retspec[retlen] = '\0';
5071             /* Convert last '.' to ']' */
5072             cp1 = retspec+retlen-1;
5073             while (*cp != '[') {
5074               cp1--;
5075               if (*cp1 == '.') {
5076                 /* Do not trip on extra dots in ODS-5 directories */
5077                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5078                 break;
5079               }
5080             }
5081             if (*cp1 == '.') *cp1 = ']';
5082             else {
5083               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5084               memmove(cp1+1,"000000]",7);
5085             }
5086           }
5087         }
5088         else {  /* This is a top-level dir.  Add the MFD to the path. */
5089           if (buf) retspec = buf;
5090           else if (ts) Newx(retspec,retlen+16,char);
5091           else retspec = __fileify_retbuf;
5092           cp1 = esa;
5093           cp2 = retspec;
5094           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5095           strcpy(cp2,":[000000]");
5096           cp1 += 2;
5097           strcpy(cp2+9,cp1);
5098         }
5099       }
5100       sts = rms_free_search_context(&dirfab);
5101       /* We've set up the string up through the filename.  Add the
5102          type and version, and we're done. */
5103       strcat(retspec,".DIR;1");
5104
5105       /* $PARSE may have upcased filespec, so convert output to lower
5106        * case if input contained any lowercase characters. */
5107       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5108       Safefree(trndir);
5109       Safefree(esa);
5110       Safefree(vmsdir);
5111       return retspec;
5112     }
5113 }  /* end of do_fileify_dirspec() */
5114 /*}}}*/
5115 /* External entry points */
5116 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5117 { return do_fileify_dirspec(dir,buf,0); }
5118 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5119 { return do_fileify_dirspec(dir,buf,1); }
5120
5121 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5122 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
5123 {
5124     static char __pathify_retbuf[VMS_MAXRSS];
5125     unsigned long int retlen;
5126     char *retpath, *cp1, *cp2, *trndir;
5127     unsigned short int trnlnm_iter_count;
5128     STRLEN trnlen;
5129     int sts;
5130
5131     if (!dir || !*dir) {
5132       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5133     }
5134
5135     Newx(trndir, VMS_MAXRSS, char);
5136     if (*dir) strcpy(trndir,dir);
5137     else getcwd(trndir,VMS_MAXRSS - 1);
5138
5139     trnlnm_iter_count = 0;
5140     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5141            && my_trnlnm(trndir,trndir,0)) {
5142       trnlnm_iter_count++;
5143       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5144       trnlen = strlen(trndir);
5145
5146       /* Trap simple rooted lnms, and return lnm:[000000] */
5147       if (!strcmp(trndir+trnlen-2,".]")) {
5148         if (buf) retpath = buf;
5149         else if (ts) Newx(retpath,strlen(dir)+10,char);
5150         else retpath = __pathify_retbuf;
5151         strcpy(retpath,dir);
5152         strcat(retpath,":[000000]");
5153         Safefree(trndir);
5154         return retpath;
5155       }
5156     }
5157
5158     /* At this point we do not work with *dir, but the copy in
5159      * *trndir that is modifiable.
5160      */
5161
5162     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5163       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5164                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5165         retlen = 2 + (*(trndir+1) != '\0');
5166       else {
5167         if ( !(cp1 = strrchr(trndir,'/')) &&
5168              !(cp1 = strrchr(trndir,']')) &&
5169              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5170         if ((cp2 = strchr(cp1,'.')) != NULL &&
5171             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5172              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5173               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5174               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5175           int ver; char *cp3;
5176
5177           /* For EFS or ODS-5 look for the last dot */
5178           if (decc_efs_charset) {
5179             cp2 = strrchr(cp1,'.');
5180           }
5181           if (vms_process_case_tolerant) {
5182               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5183                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5184                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5185                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5186                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5187                             (ver || *cp3)))))) {
5188                 Safefree(trndir);
5189                 set_errno(ENOTDIR);
5190                 set_vaxc_errno(RMS$_DIR);
5191                 return NULL;
5192               }
5193           }
5194           else {
5195               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5196                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5197                   !*(cp2+3) || *(cp2+3) != 'R' ||
5198                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5199                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5200                             (ver || *cp3)))))) {
5201                 Safefree(trndir);
5202                 set_errno(ENOTDIR);
5203                 set_vaxc_errno(RMS$_DIR);
5204                 return NULL;
5205               }
5206           }
5207           retlen = cp2 - trndir + 1;
5208         }
5209         else {  /* No file type present.  Treat the filename as a directory. */
5210           retlen = strlen(trndir) + 1;
5211         }
5212       }
5213       if (buf) retpath = buf;
5214       else if (ts) Newx(retpath,retlen+1,char);
5215       else retpath = __pathify_retbuf;
5216       strncpy(retpath, trndir, retlen-1);
5217       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5218         retpath[retlen-1] = '/';      /* with '/', add it. */
5219         retpath[retlen] = '\0';
5220       }
5221       else retpath[retlen-1] = '\0';
5222     }
5223     else {  /* VMS-style directory spec */
5224       char *esa, *cp;
5225       unsigned long int sts, cmplen, haslower;
5226       struct FAB dirfab = cc$rms_fab;
5227       int dirlen;
5228       rms_setup_nam(savnam);
5229       rms_setup_nam(dirnam);
5230
5231       /* If we've got an explicit filename, we can just shuffle the string. */
5232       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5233              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5234         if ((cp2 = strchr(cp1,'.')) != NULL) {
5235           int ver; char *cp3;
5236           if (vms_process_case_tolerant) {
5237               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5238                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5239                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5240                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5241                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5242                             (ver || *cp3)))))) {
5243                Safefree(trndir);
5244                set_errno(ENOTDIR);
5245                set_vaxc_errno(RMS$_DIR);
5246                return NULL;
5247              }
5248           }
5249           else {
5250               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5251                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5252                   !*(cp2+3) || *(cp2+3) != 'R' ||
5253                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5254                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5255                             (ver || *cp3)))))) {
5256                Safefree(trndir);
5257                set_errno(ENOTDIR);
5258                set_vaxc_errno(RMS$_DIR);
5259                return NULL;
5260              }
5261           }
5262         }
5263         else {  /* No file type, so just draw name into directory part */
5264           for (cp2 = cp1; *cp2; cp2++) ;
5265         }
5266         *cp2 = *cp1;
5267         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5268         *cp1 = '.';
5269         /* We've now got a VMS 'path'; fall through */
5270       }
5271
5272       dirlen = strlen(trndir);
5273       if (trndir[dirlen-1] == ']' ||
5274           trndir[dirlen-1] == '>' ||
5275           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5276         if (buf) retpath = buf;
5277         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5278         else retpath = __pathify_retbuf;
5279         strcpy(retpath,trndir);
5280         Safefree(trndir);
5281         return retpath;
5282       }
5283       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5284       Newx(esa, VMS_MAXRSS, char);
5285       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5286       rms_bind_fab_nam(dirfab, dirnam);
5287       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5288 #ifdef NAM$M_NO_SHORT_UPCASE
5289       if (decc_efs_case_preserve)
5290           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5291 #endif
5292
5293       for (cp = trndir; *cp; cp++)
5294         if (islower(*cp)) { haslower = 1; break; }
5295
5296       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5297         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5298           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5299           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5300         }
5301         if (!sts) {
5302           Safefree(trndir);
5303           Safefree(esa);
5304           set_errno(EVMSERR);
5305           set_vaxc_errno(dirfab.fab$l_sts);
5306           return NULL;
5307         }
5308       }
5309       else {
5310         savnam = dirnam;
5311         /* Does the file really exist? */
5312         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5313           if (dirfab.fab$l_sts != RMS$_FNF) {
5314             int sts1;
5315             sts1 = rms_free_search_context(&dirfab);
5316             Safefree(trndir);
5317             Safefree(esa);
5318             set_errno(EVMSERR);
5319             set_vaxc_errno(dirfab.fab$l_sts);
5320             return NULL;
5321           }
5322           dirnam = savnam; /* No; just work with potential name */
5323         }
5324       }
5325       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5326         /* Yep; check version while we're at it, if it's there. */
5327         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5328         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5329           int sts2;
5330           /* Something other than .DIR[;1].  Bzzt. */
5331           sts2 = rms_free_search_context(&dirfab);
5332           Safefree(trndir);
5333           Safefree(esa);
5334           set_errno(ENOTDIR);
5335           set_vaxc_errno(RMS$_DIR);
5336           return NULL;
5337         }
5338       }
5339       /* OK, the type was fine.  Now pull any file name into the
5340          directory path. */
5341       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5342       else {
5343         cp1 = strrchr(esa,'>');
5344         *(rms_nam_typel(dirnam)) = '>';
5345       }
5346       *cp1 = '.';
5347       *(rms_nam_typel(dirnam) + 1) = '\0';
5348       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5349       if (buf) retpath = buf;
5350       else if (ts) Newx(retpath,retlen,char);
5351       else retpath = __pathify_retbuf;
5352       strcpy(retpath,esa);
5353       Safefree(esa);
5354       sts = rms_free_search_context(&dirfab);
5355       /* $PARSE may have upcased filespec, so convert output to lower
5356        * case if input contained any lowercase characters. */
5357       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5358     }
5359
5360     Safefree(trndir);
5361     return retpath;
5362 }  /* end of do_pathify_dirspec() */
5363 /*}}}*/
5364 /* External entry points */
5365 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5366 { return do_pathify_dirspec(dir,buf,0); }
5367 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5368 { return do_pathify_dirspec(dir,buf,1); }
5369
5370 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5371 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5372 {
5373   static char __tounixspec_retbuf[VMS_MAXRSS];
5374   char *dirend, *rslt, *cp1, *cp3, tmp[VMS_MAXRSS];
5375   const char *cp2;
5376   int devlen, dirlen, retlen = VMS_MAXRSS;
5377   int expand = 1; /* guarantee room for leading and trailing slashes */
5378   unsigned short int trnlnm_iter_count;
5379   int cmp_rslt;
5380
5381   if (spec == NULL) return NULL;
5382   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
5383   if (buf) rslt = buf;
5384   else if (ts) {
5385     retlen = strlen(spec);
5386     cp1 = strchr(spec,'[');
5387     if (!cp1) cp1 = strchr(spec,'<');
5388     if (cp1) {
5389       for (cp1++; *cp1; cp1++) {
5390         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
5391         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
5392           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
5393       }
5394     }
5395     Newx(rslt,retlen+2+2*expand,char);
5396   }
5397   else rslt = __tounixspec_retbuf;
5398
5399   /* New VMS specific format needs translation
5400    * glob passes filenames with trailing '\n' and expects this preserved.
5401    */
5402   if (decc_posix_compliant_pathnames) {
5403     if (strncmp(spec, "\"^UP^", 5) == 0) {
5404       char * uspec;
5405       char *tunix;
5406       int tunix_len;
5407       int nl_flag;
5408
5409       Newx(tunix, VMS_MAXRSS + 1,char);
5410       strcpy(tunix, spec);
5411       tunix_len = strlen(tunix);
5412       nl_flag = 0;
5413       if (tunix[tunix_len - 1] == '\n') {
5414         tunix[tunix_len - 1] = '\"';
5415         tunix[tunix_len] = '\0';
5416         tunix_len--;
5417         nl_flag = 1;
5418       }
5419       uspec = decc$translate_vms(tunix);
5420       Safefree(tunix);
5421       if ((int)uspec > 0) {
5422         strcpy(rslt,uspec);
5423         if (nl_flag) {
5424           strcat(rslt,"\n");
5425         }
5426         else {
5427           /* If we can not translate it, makemaker wants as-is */
5428           strcpy(rslt, spec);
5429         }
5430         return rslt;
5431       }
5432     }
5433   }
5434
5435   cmp_rslt = 0; /* Presume VMS */
5436   cp1 = strchr(spec, '/');
5437   if (cp1 == NULL)
5438     cmp_rslt = 0;
5439
5440     /* Look for EFS ^/ */
5441     if (decc_efs_charset) {
5442       while (cp1 != NULL) {
5443         cp2 = cp1 - 1;
5444         if (*cp2 != '^') {
5445           /* Found illegal VMS, assume UNIX */
5446           cmp_rslt = 1;
5447           break;
5448         }
5449       cp1++;
5450       cp1 = strchr(cp1, '/');
5451     }
5452   }
5453
5454   /* Look for "." and ".." */
5455   if (decc_filename_unix_report) {
5456     if (spec[0] == '.') {
5457       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5458         cmp_rslt = 1;
5459       }
5460       else {
5461         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5462           cmp_rslt = 1;
5463         }
5464       }
5465     }
5466   }
5467   /* This is already UNIX or at least nothing VMS understands */
5468   if (cmp_rslt) {
5469     strcpy(rslt,spec);
5470     return rslt;
5471   }
5472
5473   cp1 = rslt;
5474   cp2 = spec;
5475   dirend = strrchr(spec,']');
5476   if (dirend == NULL) dirend = strrchr(spec,'>');
5477   if (dirend == NULL) dirend = strchr(spec,':');
5478   if (dirend == NULL) {
5479     strcpy(rslt,spec);
5480     return rslt;
5481   }
5482
5483   /* Special case 1 - sys$posix_root = / */
5484 #if __CRTL_VER >= 70000000
5485   if (!decc_disable_posix_root) {
5486     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5487       *cp1 = '/';
5488       cp1++;
5489       cp2 = cp2 + 15;
5490       }
5491   }
5492 #endif
5493
5494   /* Special case 2 - Convert NLA0: to /dev/null */
5495 #if __CRTL_VER < 70000000
5496   cmp_rslt = strncmp(spec,"NLA0:", 5);
5497   if (cmp_rslt != 0)
5498      cmp_rslt = strncmp(spec,"nla0:", 5);
5499 #else
5500   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5501 #endif
5502   if (cmp_rslt == 0) {
5503     strcpy(rslt, "/dev/null");
5504     cp1 = cp1 + 9;
5505     cp2 = cp2 + 5;
5506     if (spec[6] != '\0') {
5507       cp1[9] == '/';
5508       cp1++;
5509       cp2++;
5510     }
5511   }
5512
5513    /* Also handle special case "SYS$SCRATCH:" */
5514 #if __CRTL_VER < 70000000
5515   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5516   if (cmp_rslt != 0)
5517      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5518 #else
5519   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5520 #endif
5521   if (cmp_rslt == 0) {
5522   int islnm;
5523
5524     islnm = my_trnlnm(tmp, "TMP", 0);
5525     if (!islnm) {
5526       strcpy(rslt, "/tmp");
5527       cp1 = cp1 + 4;
5528       cp2 = cp2 + 12;
5529       if (spec[12] != '\0') {
5530         cp1[4] == '/';
5531         cp1++;
5532         cp2++;
5533       }
5534     }
5535   }
5536
5537   if (*cp2 != '[' && *cp2 != '<') {
5538     *(cp1++) = '/';
5539   }
5540   else {  /* the VMS spec begins with directories */
5541     cp2++;
5542     if (*cp2 == ']' || *cp2 == '>') {
5543       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5544       return rslt;
5545     }
5546     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5547       if (getcwd(tmp,sizeof tmp,1) == NULL) {
5548         if (ts) Safefree(rslt);
5549         return NULL;
5550       }
5551       trnlnm_iter_count = 0;
5552       do {
5553         cp3 = tmp;
5554         while (*cp3 != ':' && *cp3) cp3++;
5555         *(cp3++) = '\0';
5556         if (strchr(cp3,']') != NULL) break;
5557         trnlnm_iter_count++;
5558         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5559       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5560       if (ts && !buf &&
5561           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5562         retlen = devlen + dirlen;
5563         Renew(rslt,retlen+1+2*expand,char);
5564         cp1 = rslt;
5565       }
5566       cp3 = tmp;
5567       *(cp1++) = '/';
5568       while (*cp3) {
5569         *(cp1++) = *(cp3++);
5570         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
5571       }
5572       *(cp1++) = '/';
5573     }
5574     if ((*cp2 == '^')) {
5575         /* EFS file escape, pass the next character as is */
5576         /* Fix me: HEX encoding for UNICODE not implemented */
5577         cp2++;
5578     }
5579     else if ( *cp2 == '.') {
5580       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5581         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5582         cp2 += 3;
5583       }
5584       else cp2++;
5585     }
5586   }
5587   for (; cp2 <= dirend; cp2++) {
5588     if ((*cp2 == '^')) {
5589         /* EFS file escape, pass the next character as is */
5590         /* Fix me: HEX encoding for UNICODE not implemented */
5591         cp2++;
5592         *(cp1++) = *cp2;
5593     }
5594     if (*cp2 == ':') {
5595       *(cp1++) = '/';
5596       if (*(cp2+1) == '[') cp2++;
5597     }
5598     else if (*cp2 == ']' || *cp2 == '>') {
5599       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5600     }
5601     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5602       *(cp1++) = '/';
5603       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5604         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5605                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5606         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5607             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5608       }
5609       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5610         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5611         cp2 += 2;
5612       }
5613     }
5614     else if (*cp2 == '-') {
5615       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5616         while (*cp2 == '-') {
5617           cp2++;
5618           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5619         }
5620         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5621           if (ts) Safefree(rslt);                        /* filespecs like */
5622           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5623           return NULL;
5624         }
5625       }
5626       else *(cp1++) = *cp2;
5627     }
5628     else *(cp1++) = *cp2;
5629   }
5630   while (*cp2) *(cp1++) = *(cp2++);
5631   *cp1 = '\0';
5632
5633   /* This still leaves /000000/ when working with a
5634    * VMS device root or concealed root.
5635    */
5636   {
5637   int ulen;
5638   char * zeros;
5639
5640       ulen = strlen(rslt);
5641
5642       /* Get rid of "000000/ in rooted filespecs */
5643       if (ulen > 7) {
5644         zeros = strstr(rslt, "/000000/");
5645         if (zeros != NULL) {
5646           int mlen;
5647           mlen = ulen - (zeros - rslt) - 7;
5648           memmove(zeros, &zeros[7], mlen);
5649           ulen = ulen - 7;
5650           rslt[ulen] = '\0';
5651         }
5652       }
5653   }
5654
5655   return rslt;
5656
5657 }  /* end of do_tounixspec() */
5658 /*}}}*/
5659 /* External entry points */
5660 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5661 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5662
5663 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5664
5665 static int posix_to_vmsspec
5666   (char *vmspath, int vmspath_len, const char *unixpath) {
5667 int sts;
5668 struct FAB myfab = cc$rms_fab;
5669 struct NAML mynam = cc$rms_naml;
5670 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5671  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5672 char *esa;
5673 char *vms_delim;
5674 int dir_flag;
5675 int unixlen;
5676
5677   /* If not a posix spec already, convert it */
5678   dir_flag = 0;
5679   unixlen = strlen(unixpath);
5680   if (unixlen == 0) {
5681     vmspath[0] = '\0';
5682     return SS$_NORMAL;
5683   }
5684   if (strncmp(unixpath,"\"^UP^",5) != 0) {
5685     sprintf(vmspath,"\"^UP^%s\"",unixpath);
5686   }
5687   else {
5688     /* This is already a VMS specification, no conversion */
5689     unixlen--;
5690     strncpy(vmspath,unixpath, vmspath_len);
5691   }
5692   vmspath[vmspath_len] = 0;
5693   if (unixpath[unixlen - 1] == '/')
5694   dir_flag = 1;
5695   Newx(esa, VMS_MAXRSS, char);
5696   myfab.fab$l_fna = vmspath;
5697   myfab.fab$b_fns = strlen(vmspath);
5698   myfab.fab$l_naml = &mynam;
5699   mynam.naml$l_esa = NULL;
5700   mynam.naml$b_ess = 0;
5701   mynam.naml$l_long_expand = esa;
5702   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5703   mynam.naml$l_rsa = NULL;
5704   mynam.naml$b_rss = 0;
5705   if (decc_efs_case_preserve)
5706     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5707   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5708
5709   /* Set up the remaining naml fields */
5710   sts = sys$parse(&myfab);
5711
5712   /* It failed! Try again as a UNIX filespec */
5713   if (!(sts & 1)) {
5714     Safefree(esa);
5715     return sts;
5716   }
5717
5718    /* get the Device ID and the FID */
5719    sts = sys$search(&myfab);
5720    /* on any failure, returned the POSIX ^UP^ filespec */
5721    if (!(sts & 1)) {
5722       Safefree(esa);
5723       return sts;
5724    }
5725    specdsc.dsc$a_pointer = vmspath;
5726    specdsc.dsc$w_length = vmspath_len;
5727
5728    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5729    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5730    sts = lib$fid_to_name
5731       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5732
5733   /* on any failure, returned the POSIX ^UP^ filespec */
5734   if (!(sts & 1)) {
5735      /* This can happen if user does not have permission to read directories */
5736      if (strncmp(unixpath,"\"^UP^",5) != 0)
5737        sprintf(vmspath,"\"^UP^%s\"",unixpath);
5738      else
5739        strcpy(vmspath, unixpath);
5740   }
5741   else {
5742     vmspath[specdsc.dsc$w_length] = 0;
5743
5744     /* Are we expecting a directory? */
5745     if (dir_flag != 0) {
5746     int i;
5747     char *eptr;
5748
5749       eptr = NULL;
5750
5751       i = specdsc.dsc$w_length - 1;
5752       while (i > 0) {
5753       int zercnt;
5754         zercnt = 0;
5755         /* Version must be '1' */
5756         if (vmspath[i--] != '1')
5757           break;
5758         /* Version delimiter is one of ".;" */
5759         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5760           break;
5761         i--;
5762         if (vmspath[i--] != 'R')
5763           break;
5764         if (vmspath[i--] != 'I')
5765           break;
5766         if (vmspath[i--] != 'D')
5767           break;
5768         if (vmspath[i--] != '.')
5769           break;
5770         eptr = &vmspath[i+1];
5771         while (i > 0) {
5772           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5773             if (vmspath[i-1] != '^') {
5774               if (zercnt != 6) {
5775                 *eptr = vmspath[i];
5776                 eptr[1] = '\0';
5777                 vmspath[i] = '.';
5778                 break;
5779               }
5780               else {
5781                 /* Get rid of 6 imaginary zero directory filename */
5782                 vmspath[i+1] = '\0';
5783               }
5784             }
5785           }
5786           if (vmspath[i] == '0')
5787             zercnt++;
5788           else
5789             zercnt = 10;
5790           i--;
5791         }
5792         break;
5793       }
5794     }
5795   }
5796   Safefree(esa);
5797   return sts;
5798 }
5799
5800 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5801 static int posix_to_vmsspec_hardway
5802   (char *vmspath, int vmspath_len, const char *unixpath) {
5803
5804 char *esa;
5805 const char *unixptr;
5806 char *vmsptr;
5807 const char *lastslash;
5808 const char *lastdot;
5809 int unixlen;
5810 int vmslen;
5811 int dir_start;
5812 int dir_dot;
5813 int quoted;
5814
5815
5816   unixptr = unixpath;
5817   dir_dot = 0;
5818
5819   /* Ignore leading "/" characters */
5820   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5821     unixptr++;
5822   }
5823   unixlen = strlen(unixptr);
5824
5825   /* Do nothing with blank paths */
5826   if (unixlen == 0) {
5827     vmspath[0] = '\0';
5828     return SS$_NORMAL;
5829   }
5830
5831   lastslash = strrchr(unixptr,'/');
5832   lastdot = strrchr(unixptr,'.');
5833
5834
5835   /* last dot is last dot or past end of string */
5836   if (lastdot == NULL)
5837     lastdot = unixptr + unixlen;
5838
5839   /* if no directories, set last slash to beginning of string */
5840   if (lastslash == NULL) {
5841     lastslash = unixptr;
5842   }
5843   else {
5844     /* Watch out for trailing "." after last slash, still a directory */
5845     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5846       lastslash = unixptr + unixlen;
5847     }
5848
5849     /* Watch out for traiing ".." after last slash, still a directory */
5850     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5851       lastslash = unixptr + unixlen;
5852     }
5853
5854     /* dots in directories are aways escaped */
5855     if (lastdot < lastslash)
5856       lastdot = unixptr + unixlen;
5857   }
5858
5859   /* if (unixptr < lastslash) then we are in a directory */
5860
5861   dir_start = 0;
5862   quoted = 0;
5863
5864   vmsptr = vmspath;
5865   vmslen = 0;
5866
5867   /* This could have a "^UP^ on the front */
5868   if (strncmp(unixptr,"\"^UP^",5) == 0) {
5869     quoted = 1;
5870     unixptr+= 5;
5871   }
5872
5873   /* Start with the UNIX path */
5874   if (*unixptr != '/') {
5875     /* relative paths */
5876     if (lastslash > unixptr) {
5877     int dotdir_seen;
5878
5879       /* skip leading ./ */
5880       dotdir_seen = 0;
5881       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5882         dotdir_seen = 1;
5883         unixptr++;
5884         unixptr++;
5885       }
5886
5887       /* Are we still in a directory? */
5888       if (unixptr <= lastslash) {
5889         *vmsptr++ = '[';
5890         vmslen = 1;
5891         dir_start = 1;
5892
5893         /* if not backing up, then it is relative forward. */
5894         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5895               ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5896           *vmsptr++ = '.';
5897           vmslen++;
5898           dir_dot = 1;
5899         }
5900        }
5901        else {
5902          if (dotdir_seen) {
5903            /* Perl wants an empty directory here to tell the difference
5904             * between a DCL commmand and a filename
5905             */
5906           *vmsptr++ = '[';
5907           *vmsptr++ = ']';
5908           vmslen = 2;
5909         }
5910       }
5911     }
5912     else {
5913       /* Handle two special files . and .. */
5914       if (unixptr[0] == '.') {
5915         if (unixptr[1] == '\0') {
5916           *vmsptr++ = '[';
5917           *vmsptr++ = ']';
5918           vmslen += 2;
5919           *vmsptr++ = '\0';
5920           return SS$_NORMAL;
5921         }
5922         if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5923           *vmsptr++ = '[';
5924           *vmsptr++ = '-';
5925           *vmsptr++ = ']';
5926           vmslen += 3;
5927           *vmsptr++ = '\0';
5928           return SS$_NORMAL;
5929         }
5930       }
5931     }
5932   }
5933   else {        /* Absolute PATH handling */
5934   int sts;
5935   char * nextslash;
5936   int seg_len;
5937     /* Need to find out where root is */
5938
5939     /* In theory, this procedure should never get an absolute POSIX pathname
5940      * that can not be found on the POSIX root.
5941      * In practice, that can not be relied on, and things will show up
5942      * here that are a VMS device name or concealed logical name instead.
5943      * So to make things work, this procedure must be tolerant.
5944      */
5945     Newx(esa, vmspath_len, char);
5946
5947     sts = SS$_NORMAL;
5948     nextslash = strchr(&unixptr[1],'/');
5949     seg_len = 0;
5950     if (nextslash != NULL) {
5951       seg_len = nextslash - &unixptr[1];
5952       strncpy(vmspath, unixptr, seg_len + 1);
5953       vmspath[seg_len+1] = 0;
5954       sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5955     }
5956
5957     if (sts & 1) {
5958       /* This is verified to be a real path */
5959
5960       sts = posix_to_vmsspec(esa, vmspath_len, "/");
5961       strcpy(vmspath, esa);
5962       vmslen = strlen(vmspath);
5963       vmsptr = vmspath + vmslen;
5964       unixptr++;
5965       if (unixptr < lastslash) {
5966       char * rptr;
5967         vmsptr--;
5968         *vmsptr++ = '.';
5969         dir_start = 1;
5970         dir_dot = 1;
5971         if (vmslen > 7) {
5972         int cmp;
5973           rptr = vmsptr - 7;
5974           cmp = strcmp(rptr,"000000.");
5975           if (cmp == 0) {
5976             vmslen -= 7;
5977             vmsptr -= 7;
5978             vmsptr[1] = '\0';
5979           } /* removing 6 zeros */
5980         } /* vmslen < 7, no 6 zeros possible */
5981       } /* Not in a directory */
5982     } /* end of verified real path handling */
5983     else {
5984     int add_6zero;
5985     int islnm;
5986
5987       /* Ok, we have a device or a concealed root that is not in POSIX
5988        * or we have garbage.  Make the best of it.
5989        */
5990
5991       /* Posix to VMS destroyed this, so copy it again */
5992       strncpy(vmspath, &unixptr[1], seg_len);
5993       vmspath[seg_len] = 0;
5994       vmslen = seg_len;
5995       vmsptr = &vmsptr[vmslen];
5996       islnm = 0;
5997
5998       /* Now do we need to add the fake 6 zero directory to it? */
5999       add_6zero = 1;
6000       if ((*lastslash == '/') && (nextslash < lastslash)) {
6001         /* No there is another directory */
6002         add_6zero = 0;
6003       }
6004       else {
6005       int trnend;
6006
6007         /* now we have foo:bar or foo:[000000]bar to decide from */
6008         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6009         trnend = islnm ? islnm - 1 : 0;
6010
6011         /* if this was a logical name, ']' or '>' must be present */
6012         /* if not a logical name, then assume a device and hope. */
6013         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6014
6015         /* if log name and trailing '.' then rooted - treat as device */
6016         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6017
6018         /* Fix me, if not a logical name, a device lookup should be
6019          * done to see if the device is file structured.  If the device
6020          * is not file structured, the 6 zeros should not be put on.
6021          *
6022          * As it is, perl is occasionally looking for dev:[000000]tty.
6023          * which looks a little strange.
6024          */
6025
6026         if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
6027           /* No real directory present */
6028           add_6zero = 1;
6029         }
6030       }
6031
6032       /* Put the device delimiter on */
6033       *vmsptr++ = ':';
6034       vmslen++;
6035       unixptr = nextslash;
6036       unixptr++;
6037
6038       /* Start directory if needed */
6039       if (!islnm || add_6zero) {
6040         *vmsptr++ = '[';
6041         vmslen++;
6042         dir_start = 1;
6043       }
6044
6045       /* add fake 000000] if needed */
6046       if (add_6zero) {
6047         *vmsptr++ = '0';
6048         *vmsptr++ = '0';
6049         *vmsptr++ = '0';
6050         *vmsptr++ = '0';
6051         *vmsptr++ = '0';
6052         *vmsptr++ = '0';
6053         *vmsptr++ = ']';
6054         vmslen += 7;
6055         dir_start = 0;
6056       }
6057
6058     } /* non-POSIX translation */
6059     Safefree(esa);
6060   } /* End of relative/absolute path handling */
6061
6062   while ((*unixptr) && (vmslen < vmspath_len)){
6063   int dash_flag;
6064
6065     dash_flag = 0;
6066
6067     if (dir_start != 0) {
6068
6069       /* First characters in a directory are handled special */
6070       while ((*unixptr == '/') ||
6071              ((*unixptr == '.') &&
6072               ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
6073       int loop_flag;
6074
6075         loop_flag = 0;
6076
6077         /* Skip redundant / in specification */
6078         while ((*unixptr == '/') && (dir_start != 0)) {
6079           loop_flag = 1;
6080           unixptr++;
6081           if (unixptr == lastslash)
6082             break;
6083         }
6084         if (unixptr == lastslash)
6085           break;
6086
6087         /* Skip redundant ./ characters */
6088         while ((*unixptr == '.') &&
6089                ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
6090           loop_flag = 1;
6091           unixptr++;
6092           if (unixptr == lastslash)
6093             break;
6094           if (*unixptr == '/')
6095             unixptr++;
6096         }
6097         if (unixptr == lastslash)
6098           break;
6099
6100         /* Skip redundant ../ characters */
6101         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6102              ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
6103           /* Set the backing up flag */
6104           loop_flag = 1;
6105           dir_dot = 0;
6106           dash_flag = 1;
6107           *vmsptr++ = '-';
6108           vmslen++;
6109           unixptr++; /* first . */
6110           unixptr++; /* second . */
6111           if (unixptr == lastslash)
6112             break;
6113           if (*unixptr == '/') /* The slash */
6114             unixptr++;
6115         }
6116         if (unixptr == lastslash)
6117           break;
6118
6119         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6120         /* Not needed when VMS is pretending to be UNIX. */
6121
6122         /* Is this loop stuck because of too many dots? */
6123         if (loop_flag == 0) {
6124           /* Exit the loop and pass the rest through */
6125           break;
6126         }
6127       }
6128
6129       /* Are we done with directories yet? */
6130       if (unixptr >= lastslash) {
6131
6132         /* Watch out for trailing dots */
6133         if (dir_dot != 0) {
6134             vmslen --;
6135             vmsptr--;
6136         }
6137         *vmsptr++ = ']';
6138         vmslen++;
6139         dash_flag = 0;
6140         dir_start = 0;
6141         if (*unixptr == '/')
6142           unixptr++;
6143       }
6144       else {
6145         /* Have we stopped backing up? */
6146         if (dash_flag) {
6147           *vmsptr++ = '.';
6148           vmslen++;
6149           dash_flag = 0;
6150           /* dir_start continues to be = 1 */
6151         }
6152         if (*unixptr == '-') {
6153           *vmsptr++ = '^';
6154           *vmsptr++ = *unixptr++;
6155           vmslen += 2;
6156           dir_start = 0;
6157
6158           /* Now are we done with directories yet? */
6159           if (unixptr >= lastslash) {
6160
6161             /* Watch out for trailing dots */
6162             if (dir_dot != 0) {
6163               vmslen --;
6164               vmsptr--;
6165             }
6166
6167             *vmsptr++ = ']';
6168             vmslen++;
6169             dash_flag = 0;
6170             dir_start = 0;
6171           }
6172         }
6173       }
6174     }
6175
6176     /* All done? */
6177     if (*unixptr == '\0')
6178       break;
6179
6180     /* Normal characters - More EFS work probably needed */
6181     dir_start = 0;
6182     dir_dot = 0;
6183
6184     switch(*unixptr) {
6185     case '/':
6186         /* remove multiple / */
6187         while (unixptr[1] == '/') {
6188            unixptr++;
6189         }
6190         if (unixptr == lastslash) {
6191           /* Watch out for trailing dots */
6192           if (dir_dot != 0) {
6193             vmslen --;
6194             vmsptr--;
6195           }
6196           *vmsptr++ = ']';
6197         }
6198         else {
6199           dir_start = 1;
6200           *vmsptr++ = '.';
6201           dir_dot = 1;
6202
6203           /* To do: Perl expects /.../ to be translated to [...] on VMS */
6204           /* Not needed when VMS is pretending to be UNIX. */
6205
6206         }
6207         dash_flag = 0;
6208         if (*unixptr != '\0')
6209           unixptr++;
6210         vmslen++;
6211         break;
6212     case '?':
6213         *vmsptr++ = '%';
6214         vmslen++;
6215         unixptr++;
6216         break;
6217     case ' ':
6218         *vmsptr++ = '^';
6219         *vmsptr++ = '_';
6220         vmslen += 2;
6221         unixptr++;
6222         break;
6223     case '.':
6224         if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
6225           *vmsptr++ = '^';
6226           *vmsptr++ = '.';
6227           vmslen += 2;
6228           unixptr++;
6229
6230           /* trailing dot ==> '^..' on VMS */
6231           if (*unixptr == '\0') {
6232             *vmsptr++ = '.';
6233             vmslen++;
6234           }
6235           *vmsptr++ = *unixptr++;
6236           vmslen ++;
6237         }
6238         if (quoted && (unixptr[1] == '\0')) {
6239           unixptr++;
6240           break;
6241         }
6242         *vmsptr++ = '^';
6243         *vmsptr++ = *unixptr++;
6244         vmslen += 2;
6245         break;
6246     case '~':
6247     case ';':
6248     case '\\':
6249         *vmsptr++ = '^';
6250         *vmsptr++ = *unixptr++;
6251         vmslen += 2;
6252         break;
6253     default:
6254         if (*unixptr != '\0') {
6255           *vmsptr++ = *unixptr++;
6256           vmslen++;
6257         }
6258         break;
6259     }
6260   }
6261
6262   /* Make sure directory is closed */
6263   if (unixptr == lastslash) {
6264     char *vmsptr2;
6265     vmsptr2 = vmsptr - 1;
6266
6267     if (*vmsptr2 != ']') {
6268       *vmsptr2--;
6269
6270       /* directories do not end in a dot bracket */
6271       if (*vmsptr2 == '.') {
6272         vmsptr2--;
6273
6274         /* ^. is allowed */
6275         if (*vmsptr2 != '^') {
6276           vmsptr--; /* back up over the dot */
6277         }
6278       }
6279       *vmsptr++ = ']';
6280     }
6281   }
6282   else {
6283     char *vmsptr2;
6284     /* Add a trailing dot if a file with no extension */
6285     vmsptr2 = vmsptr - 1;
6286     if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6287         (*lastdot != '.')) {
6288         *vmsptr++ = '.';
6289         vmslen++;
6290     }
6291   }
6292
6293   *vmsptr = '\0';
6294   return SS$_NORMAL;
6295 }
6296 #endif
6297
6298 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6299 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6300   static char __tovmsspec_retbuf[VMS_MAXRSS];
6301   char *rslt, *dirend;
6302   char *lastdot;
6303   char *vms_delim;
6304   register char *cp1;
6305   const char *cp2;
6306   unsigned long int infront = 0, hasdir = 1;
6307   int rslt_len;
6308   int no_type_seen;
6309
6310   if (path == NULL) return NULL;
6311   rslt_len = VMS_MAXRSS;
6312   if (buf) rslt = buf;
6313   else if (ts) Newx(rslt, VMS_MAXRSS, char);
6314   else rslt = __tovmsspec_retbuf;
6315   if (strpbrk(path,"]:>") ||
6316       (dirend = strrchr(path,'/')) == NULL) {
6317     if (path[0] == '.') {
6318       if (path[1] == '\0') strcpy(rslt,"[]");
6319       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6320       else strcpy(rslt,path); /* probably garbage */
6321     }
6322     else strcpy(rslt,path);
6323     return rslt;
6324   }
6325
6326    /* Posix specifications are now a native VMS format */
6327   /*--------------------------------------------------*/
6328 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6329   if (decc_posix_compliant_pathnames) {
6330     if (strncmp(path,"\"^UP^",5) == 0) {
6331       posix_to_vmsspec_hardway(rslt, rslt_len, path);
6332       return rslt;
6333     }
6334   }
6335 #endif
6336
6337   vms_delim = strpbrk(path,"]:>");
6338
6339   if ((vms_delim != NULL) ||
6340       ((dirend = strrchr(path,'/')) == NULL)) {
6341
6342     /* VMS special characters found! */
6343
6344     if (path[0] == '.') {
6345       if (path[1] == '\0') strcpy(rslt,"[]");
6346       else if (path[1] == '.' && path[2] == '\0')
6347         strcpy(rslt,"[-]");
6348
6349       /* Dot preceeding a device or directory ? */
6350       else {
6351         /* If not in POSIX mode, pass it through and hope it works */
6352 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6353         if (!decc_posix_compliant_pathnames)
6354           strcpy(rslt,path); /* probably garbage */
6355         else
6356           posix_to_vmsspec_hardway(rslt, rslt_len, path);
6357 #else
6358         strcpy(rslt,path); /* probably garbage */
6359 #endif
6360       }
6361     }
6362     else {
6363
6364        /* If no VMS characters and in POSIX mode, convert it!
6365         * This is the easiest way to get directory specifications
6366         * handled correctly in POSIX mode
6367         */
6368 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6369       if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6370         posix_to_vmsspec_hardway(rslt, rslt_len, path);
6371       else {
6372         /* No unix path separators - presume VMS already */
6373         strcpy(rslt,path);
6374       }
6375 #else
6376       strcpy(rslt,path); /* probably garbage */
6377 #endif
6378     }
6379     return rslt;
6380   }
6381
6382 /* If POSIX mode active, handle the conversion */
6383 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6384   if (decc_posix_compliant_pathnames) {
6385     posix_to_vmsspec_hardway(rslt, rslt_len, path);
6386     return rslt;
6387   }
6388 #endif
6389
6390   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
6391     if (!*(dirend+2)) dirend +=2;
6392     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6393     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6394   }
6395
6396   cp1 = rslt;
6397   cp2 = path;
6398   lastdot = strrchr(cp2,'.');
6399   if (*cp2 == '/') {
6400     char *trndev;
6401     int islnm, rooted;
6402     STRLEN trnend;
6403
6404     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6405     if (!*(cp2+1)) {
6406       if (decc_disable_posix_root) {
6407         strcpy(rslt,"sys$disk:[000000]");
6408       }
6409       else {
6410         strcpy(rslt,"sys$posix_root:[000000]");
6411       }
6412       return rslt;
6413     }
6414     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6415     *cp1 = '\0';
6416     Newx(trndev, VMS_MAXRSS, char);
6417     islnm =  my_trnlnm(rslt,trndev,0);
6418
6419      /* DECC special handling */
6420     if (!islnm) {
6421       if (strcmp(rslt,"bin") == 0) {
6422         strcpy(rslt,"sys$system");
6423         cp1 = rslt + 10;
6424         *cp1 = 0;
6425         islnm =  my_trnlnm(rslt,trndev,0);
6426       }
6427       else if (strcmp(rslt,"tmp") == 0) {
6428         strcpy(rslt,"sys$scratch");
6429         cp1 = rslt + 11;
6430         *cp1 = 0;
6431         islnm =  my_trnlnm(rslt,trndev,0);
6432       }
6433       else if (!decc_disable_posix_root) {
6434         strcpy(rslt, "sys$posix_root");
6435         cp1 = rslt + 13;
6436         *cp1 = 0;
6437         cp2 = path;
6438         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6439         islnm =  my_trnlnm(rslt,trndev,0);
6440       }
6441       else if (strcmp(rslt,"dev") == 0) {
6442         if (strncmp(cp2,"/null", 5) == 0) {
6443           if ((cp2[5] == 0) || (cp2[5] == '/')) {
6444             strcpy(rslt,"NLA0");
6445             cp1 = rslt + 4;
6446             *cp1 = 0;
6447             cp2 = cp2 + 5;
6448             islnm =  my_trnlnm(rslt,trndev,0);
6449           }
6450         }
6451       }
6452     }
6453
6454     trnend = islnm ? strlen(trndev) - 1 : 0;
6455     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6456     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6457     /* If the first element of the path is a logical name, determine
6458      * whether it has to be translated so we can add more directories. */
6459     if (!islnm || rooted) {
6460       *(cp1++) = ':';
6461       *(cp1++) = '[';
6462       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6463       else cp2++;
6464     }
6465     else {
6466       if (cp2 != dirend) {
6467         strcpy(rslt,trndev);
6468         cp1 = rslt + trnend;
6469         if (*cp2 != 0) {
6470           *(cp1++) = '.';
6471           cp2++;
6472         }
6473       }
6474       else {
6475         if (decc_disable_posix_root) {
6476           *(cp1++) = ':';
6477           hasdir = 0;
6478         }
6479       }
6480     }
6481     Safefree(trndev);
6482   }
6483   else {
6484     *(cp1++) = '[';
6485     if (*cp2 == '.') {
6486       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6487         cp2 += 2;         /* skip over "./" - it's redundant */
6488         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
6489       }
6490       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6491         *(cp1++) = '-';                                 /* "../" --> "-" */
6492         cp2 += 3;
6493       }
6494       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6495                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6496         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6497         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6498         cp2 += 4;
6499       }
6500       else if ((cp2 != lastdot) || (lastdot < dirend)) {
6501         /* Escape the extra dots in EFS file specifications */
6502         *(cp1++) = '^';
6503       }
6504       if (cp2 > dirend) cp2 = dirend;
6505     }
6506     else *(cp1++) = '.';
6507   }
6508   for (; cp2 < dirend; cp2++) {
6509     if (*cp2 == '/') {
6510       if (*(cp2-1) == '/') continue;
6511       if (*(cp1-1) != '.') *(cp1++) = '.';
6512       infront = 0;
6513     }
6514     else if (!infront && *cp2 == '.') {
6515       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6516       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
6517       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6518         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6519         else if (*(cp1-2) == '[') *(cp1-1) = '-';
6520         else {  /* back up over previous directory name */
6521           cp1--;
6522           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6523           if (*(cp1-1) == '[') {
6524             memcpy(cp1,"000000.",7);
6525             cp1 += 7;
6526           }
6527         }
6528         cp2 += 2;
6529         if (cp2 == dirend) break;
6530       }
6531       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6532                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6533         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6534         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6535         if (!*(cp2+3)) {
6536           *(cp1++) = '.';  /* Simulate trailing '/' */
6537           cp2 += 2;  /* for loop will incr this to == dirend */
6538         }
6539         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
6540       }
6541       else {
6542         if (decc_efs_charset == 0)
6543           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
6544         else {
6545           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
6546           *(cp1++) = '.';
6547         }
6548       }
6549     }
6550     else {
6551       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
6552       if (*cp2 == '.') {
6553         if (decc_efs_charset == 0)
6554           *(cp1++) = '_';
6555         else {
6556           *(cp1++) = '^';
6557           *(cp1++) = '.';
6558         }
6559       }
6560       else                  *(cp1++) =  *cp2;
6561       infront = 1;
6562     }
6563   }
6564   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6565   if (hasdir) *(cp1++) = ']';
6566   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
6567   /* fixme for ODS5 */
6568   no_type_seen = 0;
6569   if (cp2 > lastdot)
6570     no_type_seen = 1;
6571   while (*cp2) {
6572     switch(*cp2) {
6573     case '?':
6574         *(cp1++) = '%';
6575         cp2++;
6576     case ' ':
6577         *(cp1)++ = '^';
6578         *(cp1)++ = '_';
6579         cp2++;
6580         break;
6581     case '.':
6582         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6583             decc_readdir_dropdotnotype) {
6584           *(cp1)++ = '^';
6585           *(cp1)++ = '.';
6586           cp2++;
6587
6588           /* trailing dot ==> '^..' on VMS */
6589           if (*cp2 == '\0') {
6590             *(cp1++) = '.';
6591             no_type_seen = 0;
6592           }
6593         }
6594         else {
6595           *(cp1++) = *(cp2++);
6596           no_type_seen = 0;
6597         }
6598         break;
6599     case '\"':
6600     case '~':
6601     case '`':
6602     case '!':
6603     case '#':
6604     case '%':
6605     case '^':
6606     case '&':
6607     case '(':
6608     case ')':
6609     case '=':
6610     case '+':
6611     case '\'':
6612     case '@':
6613     case '[':
6614     case ']':
6615     case '{':
6616     case '}':
6617     case ':':
6618     case '\\':
6619     case '|':
6620     case '<':
6621     case '>':
6622         *(cp1++) = '^';
6623         *(cp1++) = *(cp2++);
6624         break;
6625     case ';':
6626         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6627          * which is wrong.  UNIX notation should be ".dir." unless
6628          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6629          * changing this behavior could break more things at this time.
6630          * efs character set effectively does not allow "." to be a version
6631          * delimiter as a further complication about changing this.
6632          */
6633         if (decc_filename_unix_report != 0) {
6634           *(cp1++) = '^';
6635         }
6636         *(cp1++) = *(cp2++);
6637         break;
6638     default:
6639         *(cp1++) = *(cp2++);
6640     }
6641   }
6642   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6643   char *lcp1;
6644     lcp1 = cp1;
6645     lcp1--;
6646      /* Fix me for "^]", but that requires making sure that you do
6647       * not back up past the start of the filename
6648       */
6649     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6650       *cp1++ = '.';
6651   }
6652   *cp1 = '\0';
6653
6654   return rslt;
6655
6656 }  /* end of do_tovmsspec() */
6657 /*}}}*/
6658 /* External entry points */
6659 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6660 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6661
6662 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6663 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6664   static char __tovmspath_retbuf[VMS_MAXRSS];
6665   int vmslen;
6666   char *pathified, *vmsified, *cp;
6667
6668   if (path == NULL) return NULL;
6669   Newx(pathified, VMS_MAXRSS, char);
6670   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6671     Safefree(pathified);
6672     return NULL;
6673   }
6674   Newx(vmsified, VMS_MAXRSS, char);
6675   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) {
6676     Safefree(pathified);
6677     Safefree(vmsified);
6678     return NULL;
6679   }
6680   Safefree(pathified);
6681   if (buf) {
6682     Safefree(vmsified);
6683     return buf;
6684   }
6685   else if (ts) {
6686     vmslen = strlen(vmsified);
6687     Newx(cp,vmslen+1,char);
6688     memcpy(cp,vmsified,vmslen);
6689     cp[vmslen] = '\0';
6690     Safefree(vmsified);
6691     return cp;
6692   }
6693   else {
6694     strcpy(__tovmspath_retbuf,vmsified);
6695     Safefree(vmsified);
6696     return __tovmspath_retbuf;
6697   }
6698
6699 }  /* end of do_tovmspath() */
6700 /*}}}*/
6701 /* External entry points */
6702 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6703 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6704
6705
6706 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6707 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6708   static char __tounixpath_retbuf[VMS_MAXRSS];
6709   int unixlen;
6710   char *pathified, *unixified, *cp;
6711
6712   if (path == NULL) return NULL;
6713   Newx(pathified, VMS_MAXRSS, char);
6714   if (do_pathify_dirspec(path,pathified,0) == NULL) {
6715     Safefree(pathified);
6716     return NULL;
6717   }
6718   Newx(unixified, VMS_MAXRSS, char);
6719   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6720     Safefree(pathified);
6721     Safefree(unixified);
6722     return NULL;
6723   }
6724   Safefree(pathified);
6725   if (buf) {
6726     Safefree(unixified);
6727     return buf;
6728   }
6729   else if (ts) {
6730     unixlen = strlen(unixified);
6731     Newx(cp,unixlen+1,char);
6732     memcpy(cp,unixified,unixlen);
6733     cp[unixlen] = '\0';
6734     Safefree(unixified);
6735     return cp;
6736   }
6737   else {
6738     strcpy(__tounixpath_retbuf,unixified);
6739     Safefree(unixified);
6740     return __tounixpath_retbuf;
6741   }
6742
6743 }  /* end of do_tounixpath() */
6744 /*}}}*/
6745 /* External entry points */
6746 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6747 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6748
6749 /*
6750  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
6751  *
6752  *****************************************************************************
6753  *                                                                           *
6754  *  Copyright (C) 1989-1994 by                                               *
6755  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
6756  *                                                                           *
6757  *  Permission is hereby  granted for the reproduction of this software,     *
6758  *  on condition that this copyright notice is included in the reproduction, *
6759  *  and that such reproduction is not for purposes of profit or material     *
6760  *  gain.                                                                    *
6761  *                                                                           *
6762  *  27-Aug-1994 Modified for inclusion in perl5                              *
6763  *              by Charles Bailey  bailey@newman.upenn.edu                   *
6764  *****************************************************************************
6765  */
6766
6767 /*
6768  * getredirection() is intended to aid in porting C programs
6769  * to VMS (Vax-11 C).  The native VMS environment does not support
6770  * '>' and '<' I/O redirection, or command line wild card expansion,
6771  * or a command line pipe mechanism using the '|' AND background
6772  * command execution '&'.  All of these capabilities are provided to any
6773  * C program which calls this procedure as the first thing in the
6774  * main program.
6775  * The piping mechanism will probably work with almost any 'filter' type
6776  * of program.  With suitable modification, it may useful for other
6777  * portability problems as well.
6778  *
6779  * Author:  Mark Pizzolato      mark@infocomm.com
6780  */
6781 struct list_item
6782     {
6783     struct list_item *next;
6784     char *value;
6785     };
6786
6787 static void add_item(struct list_item **head,
6788                      struct list_item **tail,
6789                      char *value,
6790                      int *count);
6791
6792 static void mp_expand_wild_cards(pTHX_ char *item,
6793                                 struct list_item **head,
6794                                 struct list_item **tail,
6795                                 int *count);
6796
6797 static int background_process(pTHX_ int argc, char **argv);
6798
6799 static void pipe_and_fork(pTHX_ char **cmargv);
6800
6801 /*{{{ void getredirection(int *ac, char ***av)*/
6802 static void
6803 mp_getredirection(pTHX_ int *ac, char ***av)
6804 /*
6805  * Process vms redirection arg's.  Exit if any error is seen.
6806  * If getredirection() processes an argument, it is erased
6807  * from the vector.  getredirection() returns a new argc and argv value.
6808  * In the event that a background command is requested (by a trailing "&"),
6809  * this routine creates a background subprocess, and simply exits the program.
6810  *
6811  * Warning: do not try to simplify the code for vms.  The code
6812  * presupposes that getredirection() is called before any data is
6813  * read from stdin or written to stdout.
6814  *
6815  * Normal usage is as follows:
6816  *
6817  *      main(argc, argv)
6818  *      int             argc;
6819  *      char            *argv[];
6820  *      {
6821  *              getredirection(&argc, &argv);
6822  *      }
6823  */
6824 {
6825     int                 argc = *ac;     /* Argument Count         */
6826     char                **argv = *av;   /* Argument Vector        */
6827     char                *ap;            /* Argument pointer       */
6828     int                 j;              /* argv[] index           */
6829     int                 item_count = 0; /* Count of Items in List */
6830     struct list_item    *list_head = 0; /* First Item in List       */
6831     struct list_item    *list_tail;     /* Last Item in List        */
6832     char                *in = NULL;     /* Input File Name          */
6833     char                *out = NULL;    /* Output File Name         */
6834     char                *outmode = "w"; /* Mode to Open Output File */
6835     char                *err = NULL;    /* Error File Name          */
6836     char                *errmode = "w"; /* Mode to Open Error File  */
6837     int                 cmargc = 0;     /* Piped Command Arg Count  */
6838     char                **cmargv = NULL;/* Piped Command Arg Vector */
6839
6840     /*
6841      * First handle the case where the last thing on the line ends with
6842      * a '&'.  This indicates the desire for the command to be run in a
6843      * subprocess, so we satisfy that desire.
6844      */
6845     ap = argv[argc-1];
6846     if (0 == strcmp("&", ap))
6847        exit(background_process(aTHX_ --argc, argv));
6848     if (*ap && '&' == ap[strlen(ap)-1])
6849         {
6850         ap[strlen(ap)-1] = '\0';
6851        exit(background_process(aTHX_ argc, argv));
6852         }
6853     /*
6854      * Now we handle the general redirection cases that involve '>', '>>',
6855      * '<', and pipes '|'.
6856      */
6857     for (j = 0; j < argc; ++j)
6858         {
6859         if (0 == strcmp("<", argv[j]))
6860             {
6861             if (j+1 >= argc)
6862                 {
6863                 fprintf(stderr,"No input file after < on command line");
6864                 exit(LIB$_WRONUMARG);
6865                 }
6866             in = argv[++j];
6867             continue;
6868             }
6869         if ('<' == *(ap = argv[j]))
6870             {
6871             in = 1 + ap;
6872             continue;
6873             }
6874         if (0 == strcmp(">", ap))
6875             {
6876             if (j+1 >= argc)
6877                 {
6878                 fprintf(stderr,"No output file after > on command line");
6879                 exit(LIB$_WRONUMARG);
6880                 }
6881             out = argv[++j];
6882             continue;
6883             }
6884         if ('>' == *ap)
6885             {
6886             if ('>' == ap[1])
6887                 {
6888                 outmode = "a";
6889                 if ('\0' == ap[2])
6890                     out = argv[++j];
6891                 else
6892                     out = 2 + ap;
6893                 }
6894             else
6895                 out = 1 + ap;
6896             if (j >= argc)
6897                 {
6898                 fprintf(stderr,"No output file after > or >> on command line");
6899                 exit(LIB$_WRONUMARG);
6900                 }
6901             continue;
6902             }
6903         if (('2' == *ap) && ('>' == ap[1]))
6904             {
6905             if ('>' == ap[2])
6906                 {
6907                 errmode = "a";
6908                 if ('\0' == ap[3])
6909                     err = argv[++j];
6910                 else
6911                     err = 3 + ap;
6912                 }
6913             else
6914                 if ('\0' == ap[2])
6915                     err = argv[++j];
6916                 else
6917                     err = 2 + ap;
6918             if (j >= argc)
6919                 {
6920                 fprintf(stderr,"No output file after 2> or 2>> on command line");
6921                 exit(LIB$_WRONUMARG);
6922                 }
6923             continue;
6924             }
6925         if (0 == strcmp("|", argv[j]))
6926             {
6927             if (j+1 >= argc)
6928                 {
6929                 fprintf(stderr,"No command into which to pipe on command line");
6930                 exit(LIB$_WRONUMARG);
6931                 }
6932             cmargc = argc-(j+1);
6933             cmargv = &argv[j+1];
6934             argc = j;
6935             continue;
6936             }
6937         if ('|' == *(ap = argv[j]))
6938             {
6939             ++argv[j];
6940             cmargc = argc-j;
6941             cmargv = &argv[j];
6942             argc = j;
6943             continue;
6944             }
6945         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6946         }
6947     /*
6948      * Allocate and fill in the new argument vector, Some Unix's terminate
6949      * the list with an extra null pointer.
6950      */
6951     Newx(argv, item_count+1, char *);
6952     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
6953     *av = argv;
6954     for (j = 0; j < item_count; ++j, list_head = list_head->next)
6955         argv[j] = list_head->value;
6956     *ac = item_count;
6957     if (cmargv != NULL)
6958         {
6959         if (out != NULL)
6960             {
6961             fprintf(stderr,"'|' and '>' may not both be specified on command line");
6962             exit(LIB$_INVARGORD);
6963             }
6964         pipe_and_fork(aTHX_ cmargv);
6965         }
6966
6967     /* Check for input from a pipe (mailbox) */
6968
6969     if (in == NULL && 1 == isapipe(0))
6970         {
6971         char mbxname[L_tmpnam];
6972         long int bufsize;
6973         long int dvi_item = DVI$_DEVBUFSIZ;
6974         $DESCRIPTOR(mbxnam, "");
6975         $DESCRIPTOR(mbxdevnam, "");
6976
6977         /* Input from a pipe, reopen it in binary mode to disable       */
6978         /* carriage control processing.                                 */
6979
6980         fgetname(stdin, mbxname);
6981         mbxnam.dsc$a_pointer = mbxname;
6982         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6983         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6984         mbxdevnam.dsc$a_pointer = mbxname;
6985         mbxdevnam.dsc$w_length = sizeof(mbxname);
6986         dvi_item = DVI$_DEVNAM;
6987         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6988         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
6989         set_errno(0);
6990         set_vaxc_errno(1);
6991         freopen(mbxname, "rb", stdin);
6992         if (errno != 0)
6993             {
6994             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
6995             exit(vaxc$errno);
6996             }
6997         }
6998     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6999         {
7000         fprintf(stderr,"Can't open input file %s as stdin",in);
7001         exit(vaxc$errno);
7002         }
7003     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7004         {
7005         fprintf(stderr,"Can't open output file %s as stdout",out);
7006         exit(vaxc$errno);
7007         }
7008         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7009
7010     if (err != NULL) {
7011         if (strcmp(err,"&1") == 0) {
7012             dup2(fileno(stdout), fileno(stderr));
7013             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7014         } else {
7015         FILE *tmperr;
7016         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7017             {
7018             fprintf(stderr,"Can't open error file %s as stderr",err);
7019             exit(vaxc$errno);
7020             }
7021             fclose(tmperr);
7022            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7023                 {
7024                 exit(vaxc$errno);
7025                 }
7026             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7027         }
7028         }
7029 #ifdef ARGPROC_DEBUG
7030     PerlIO_printf(Perl_debug_log, "Arglist:\n");
7031     for (j = 0; j < *ac;  ++j)
7032         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7033 #endif
7034    /* Clear errors we may have hit expanding wildcards, so they don't
7035       show up in Perl's $! later */
7036    set_errno(0); set_vaxc_errno(1);
7037 }  /* end of getredirection() */
7038 /*}}}*/
7039
7040 static void add_item(struct list_item **head,
7041                      struct list_item **tail,
7042                      char *value,
7043                      int *count)
7044 {
7045     if (*head == 0)
7046         {
7047         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7048         *tail = *head;
7049         }
7050     else {
7051         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7052         *tail = (*tail)->next;
7053         }
7054     (*tail)->value = value;
7055     ++(*count);
7056 }
7057
7058 static void mp_expand_wild_cards(pTHX_ char *item,
7059                               struct list_item **head,
7060                               struct list_item **tail,
7061                               int *count)
7062 {
7063 int expcount = 0;
7064 unsigned long int context = 0;
7065 int isunix = 0;
7066 int item_len = 0;
7067 char *had_version;
7068 char *had_device;
7069 int had_directory;
7070 char *devdir,*cp;
7071 char *vmsspec;
7072 $DESCRIPTOR(filespec, "");
7073 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7074 $DESCRIPTOR(resultspec, "");
7075 unsigned long int lff_flags = 0;
7076 int sts;
7077
7078 #ifdef VMS_LONGNAME_SUPPORT
7079     lff_flags = LIB$M_FIL_LONG_NAMES;
7080 #endif
7081
7082     for (cp = item; *cp; cp++) {
7083         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7084         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7085     }
7086     if (!*cp || isspace(*cp))
7087         {
7088         add_item(head, tail, item, count);
7089         return;
7090         }
7091     else
7092         {
7093      /* "double quoted" wild card expressions pass as is */
7094      /* From DCL that means using e.g.:                  */
7095      /* perl program """perl.*"""                        */
7096      item_len = strlen(item);
7097      if ( '"' == *item && '"' == item[item_len-1] )
7098        {
7099        item++;
7100        item[item_len-2] = '\0';
7101        add_item(head, tail, item, count);
7102        return;
7103        }
7104      }
7105     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7106     resultspec.dsc$b_class = DSC$K_CLASS_D;
7107     resultspec.dsc$a_pointer = NULL;
7108     Newx(vmsspec, VMS_MAXRSS, char);
7109     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7110       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
7111     if (!isunix || !filespec.dsc$a_pointer)
7112       filespec.dsc$a_pointer = item;
7113     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7114     /*
7115      * Only return version specs, if the caller specified a version
7116      */
7117     had_version = strchr(item, ';');
7118     /*
7119      * Only return device and directory specs, if the caller specifed either.
7120      */
7121     had_device = strchr(item, ':');
7122     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7123
7124     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7125                                  (&filespec, &resultspec, &context,
7126                                   &defaultspec, 0, 0, &lff_flags)))
7127         {
7128         char *string;
7129         char *c;
7130
7131         Newx(string,resultspec.dsc$w_length+1,char);
7132         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7133         string[resultspec.dsc$w_length] = '\0';
7134         if (NULL == had_version)
7135             *(strrchr(string, ';')) = '\0';
7136         if ((!had_directory) && (had_device == NULL))
7137             {
7138             if (NULL == (devdir = strrchr(string, ']')))
7139                 devdir = strrchr(string, '>');
7140             strcpy(string, devdir + 1);
7141             }
7142         /*
7143          * Be consistent with what the C RTL has already done to the rest of
7144          * the argv items and lowercase all of these names.
7145          */
7146         if (!decc_efs_case_preserve) {
7147             for (c = string; *c; ++c)
7148             if (isupper(*c))
7149                 *c = tolower(*c);
7150         }
7151         if (isunix) trim_unixpath(string,item,1);
7152         add_item(head, tail, string, count);
7153         ++expcount;
7154     }
7155     Safefree(vmsspec);
7156     if (sts != RMS$_NMF)
7157         {
7158         set_vaxc_errno(sts);
7159         switch (sts)
7160             {
7161             case RMS$_FNF: case RMS$_DNF:
7162                 set_errno(ENOENT); break;
7163             case RMS$_DIR:
7164                 set_errno(ENOTDIR); break;
7165             case RMS$_DEV:
7166                 set_errno(ENODEV); break;
7167             case RMS$_FNM: case RMS$_SYN:
7168                 set_errno(EINVAL); break;
7169             case RMS$_PRV:
7170                 set_errno(EACCES); break;
7171             default:
7172                 _ckvmssts_noperl(sts);
7173             }
7174         }
7175     if (expcount == 0)
7176         add_item(head, tail, item, count);
7177     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7178     _ckvmssts_noperl(lib$find_file_end(&context));
7179 }
7180
7181 static int child_st[2];/* Event Flag set when child process completes   */
7182
7183 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
7184
7185 static unsigned long int exit_handler(int *status)
7186 {
7187 short iosb[4];
7188
7189     if (0 == child_st[0])
7190         {
7191 #ifdef ARGPROC_DEBUG
7192         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7193 #endif
7194         fflush(stdout);     /* Have to flush pipe for binary data to    */
7195                             /* terminate properly -- <tp@mccall.com>    */
7196         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7197         sys$dassgn(child_chan);
7198         fclose(stdout);
7199         sys$synch(0, child_st);
7200         }
7201     return(1);
7202 }
7203
7204 static void sig_child(int chan)
7205 {
7206 #ifdef ARGPROC_DEBUG
7207     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7208 #endif
7209     if (child_st[0] == 0)
7210         child_st[0] = 1;
7211 }
7212
7213 static struct exit_control_block exit_block =
7214     {
7215     0,
7216     exit_handler,
7217     1,
7218     &exit_block.exit_status,
7219     0
7220     };
7221
7222 static void
7223 pipe_and_fork(pTHX_ char **cmargv)
7224 {
7225     PerlIO *fp;
7226     struct dsc$descriptor_s *vmscmd;
7227     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7228     int sts, j, l, ismcr, quote, tquote = 0;
7229
7230     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
7231     vms_execfree(vmscmd);
7232
7233     j = l = 0;
7234     p = subcmd;
7235     q = cmargv[0];
7236     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
7237               && toupper(*(q+2)) == 'R' && !*(q+3);
7238
7239     while (q && l < MAX_DCL_LINE_LENGTH) {
7240         if (!*q) {
7241             if (j > 0 && quote) {
7242                 *p++ = '"';
7243                 l++;
7244             }
7245             q = cmargv[++j];
7246             if (q) {
7247                 if (ismcr && j > 1) quote = 1;
7248                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
7249                 *p++ = ' ';
7250                 l++;
7251                 if (quote || tquote) {
7252                     *p++ = '"';
7253                     l++;
7254                 }
7255         }
7256         } else {
7257             if ((quote||tquote) && *q == '"') {
7258                 *p++ = '"';
7259                 l++;
7260         }
7261             *p++ = *q++;
7262             l++;
7263         }
7264     }
7265     *p = '\0';
7266
7267     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7268     if (fp == Nullfp) {
7269         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7270         }
7271 }
7272
7273 static int background_process(pTHX_ int argc, char **argv)
7274 {
7275 char command[MAX_DCL_SYMBOL + 1] = "$";
7276 $DESCRIPTOR(value, "");
7277 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7278 static $DESCRIPTOR(null, "NLA0:");
7279 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7280 char pidstring[80];
7281 $DESCRIPTOR(pidstr, "");
7282 int pid;
7283 unsigned long int flags = 17, one = 1, retsts;
7284 int len;
7285
7286     strcat(command, argv[0]);
7287     len = strlen(command);
7288     while (--argc && (len < MAX_DCL_SYMBOL))
7289         {
7290         strcat(command, " \"");
7291         strcat(command, *(++argv));
7292         strcat(command, "\"");
7293         len = strlen(command);
7294         }
7295     value.dsc$a_pointer = command;
7296     value.dsc$w_length = strlen(value.dsc$a_pointer);
7297     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7298     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7299     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7300         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7301     }
7302     else {
7303         _ckvmssts_noperl(retsts);
7304     }
7305 #ifdef ARGPROC_DEBUG
7306     PerlIO_printf(Perl_debug_log, "%s\n", command);
7307 #endif
7308     sprintf(pidstring, "%08X", pid);
7309     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7310     pidstr.dsc$a_pointer = pidstring;
7311     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7312     lib$set_symbol(&pidsymbol, &pidstr);
7313     return(SS$_NORMAL);
7314 }
7315 /*}}}*/
7316 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7317
7318
7319 /* OS-specific initialization at image activation (not thread startup) */
7320 /* Older VAXC header files lack these constants */
7321 #ifndef JPI$_RIGHTS_SIZE
7322 #  define JPI$_RIGHTS_SIZE 817
7323 #endif
7324 #ifndef KGB$M_SUBSYSTEM
7325 #  define KGB$M_SUBSYSTEM 0x8
7326 #endif
7327
7328 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7329
7330 /*{{{void vms_image_init(int *, char ***)*/
7331 void
7332 vms_image_init(int *argcp, char ***argvp)
7333 {
7334   char eqv[LNM$C_NAMLENGTH+1] = "";
7335   unsigned int len, tabct = 8, tabidx = 0;
7336   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7337   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7338   unsigned short int dummy, rlen;
7339   struct dsc$descriptor_s **tabvec;
7340 #if defined(PERL_IMPLICIT_CONTEXT)
7341   pTHX = NULL;
7342 #endif
7343   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
7344                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
7345                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7346                                  {          0,                0,    0,      0} };
7347
7348 #ifdef KILL_BY_SIGPRC
7349     Perl_csighandler_init();
7350 #endif
7351
7352   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7353   _ckvmssts_noperl(iosb[0]);
7354   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7355     if (iprv[i]) {           /* Running image installed with privs? */
7356       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
7357       will_taint = TRUE;
7358       break;
7359     }
7360   }
7361   /* Rights identifiers might trigger tainting as well. */
7362   if (!will_taint && (rlen || rsz)) {
7363     while (rlen < rsz) {
7364       /* We didn't get all the identifiers on the first pass.  Allocate a
7365        * buffer much larger than $GETJPI wants (rsz is size in bytes that
7366        * were needed to hold all identifiers at time of last call; we'll
7367        * allocate that many unsigned long ints), and go back and get 'em.
7368        * If it gave us less than it wanted to despite ample buffer space,
7369        * something's broken.  Is your system missing a system identifier?
7370        */
7371       if (rsz <= jpilist[1].buflen) {
7372          /* Perl_croak accvios when used this early in startup. */
7373          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7374                          rsz, (unsigned long) jpilist[1].buflen,
7375                          "Check your rights database for corruption.\n");
7376          exit(SS$_ABORT);
7377       }
7378       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7379       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7380       jpilist[1].buflen = rsz * sizeof(unsigned long int);
7381       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7382       _ckvmssts_noperl(iosb[0]);
7383     }
7384     mask = jpilist[1].bufadr;
7385     /* Check attribute flags for each identifier (2nd longword); protected
7386      * subsystem identifiers trigger tainting.
7387      */
7388     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7389       if (mask[i] & KGB$M_SUBSYSTEM) {
7390         will_taint = TRUE;
7391         break;
7392       }
7393     }
7394     if (mask != rlst) Safefree(mask);
7395   }
7396
7397   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7398    * logical, some versions of the CRTL will add a phanthom /000000/
7399    * directory.  This needs to be removed.
7400    */
7401   if (decc_filename_unix_report) {
7402   char * zeros;
7403   int ulen;
7404     ulen = strlen(argvp[0][0]);
7405     if (ulen > 7) {
7406       zeros = strstr(argvp[0][0], "/000000/");
7407       if (zeros != NULL) {
7408         int mlen;
7409         mlen = ulen - (zeros - argvp[0][0]) - 7;
7410         memmove(zeros, &zeros[7], mlen);
7411         ulen = ulen - 7;
7412         argvp[0][0][ulen] = '\0';
7413       }
7414     }
7415     /* It also may have a trailing dot that needs to be removed otherwise
7416      * it will be converted to VMS mode incorrectly.
7417      */
7418     ulen--;
7419     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7420       argvp[0][0][ulen] = '\0';
7421   }
7422
7423   /* We need to use this hack to tell Perl it should run with tainting,
7424    * since its tainting flag may be part of the PL_curinterp struct, which
7425    * hasn't been allocated when vms_image_init() is called.
7426    */
7427   if (will_taint) {
7428     char **newargv, **oldargv;
7429     oldargv = *argvp;
7430     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7431     newargv[0] = oldargv[0];
7432     newargv[1] = (char *) PerlMem_malloc(3 * sizeof(char));
7433     strcpy(newargv[1], "-T");
7434     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7435     (*argcp)++;
7436     newargv[*argcp] = NULL;
7437     /* We orphan the old argv, since we don't know where it's come from,
7438      * so we don't know how to free it.
7439      */
7440     *argvp = newargv;
7441   }
7442   else {  /* Did user explicitly request tainting? */
7443     int i;
7444     char *cp, **av = *argvp;
7445     for (i = 1; i < *argcp; i++) {
7446       if (*av[i] != '-') break;
7447       for (cp = av[i]+1; *cp; cp++) {
7448         if (*cp == 'T') { will_taint = 1; break; }
7449         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7450                   strchr("DFIiMmx",*cp)) break;
7451       }
7452       if (will_taint) break;
7453     }
7454   }
7455
7456   for (tabidx = 0;
7457        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7458        tabidx++) {
7459     if (!tabidx) tabvec = (struct dsc$descriptor_s **) PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7460     else if (tabidx >= tabct) {
7461       tabct += 8;
7462       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7463     }
7464     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7465     tabvec[tabidx]->dsc$w_length  = 0;
7466     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
7467     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
7468     tabvec[tabidx]->dsc$a_pointer = NULL;
7469     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7470   }
7471   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7472
7473   getredirection(argcp,argvp);
7474 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7475   {
7476 # include <reentrancy.h>
7477   decc$set_reentrancy(C$C_MULTITHREAD);
7478   }
7479 #endif
7480   return;
7481 }
7482 /*}}}*/
7483
7484
7485 /* trim_unixpath()
7486  * Trim Unix-style prefix off filespec, so it looks like what a shell
7487  * glob expansion would return (i.e. from specified prefix on, not
7488  * full path).  Note that returned filespec is Unix-style, regardless
7489  * of whether input filespec was VMS-style or Unix-style.
7490  *
7491  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7492  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
7493  * vector of options; at present, only bit 0 is used, and if set tells
7494  * trim unixpath to try the current default directory as a prefix when
7495  * presented with a possibly ambiguous ... wildcard.
7496  *
7497  * Returns !=0 on success, with trimmed filespec replacing contents of
7498  * fspec, and 0 on failure, with contents of fpsec unchanged.
7499  */
7500 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7501 int
7502 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7503 {
7504   char *unixified, *unixwild,
7505        *template, *base, *end, *cp1, *cp2;
7506   register int tmplen, reslen = 0, dirs = 0;
7507
7508   Newx(unixwild, VMS_MAXRSS, char);
7509   if (!wildspec || !fspec) return 0;
7510   template = unixwild;
7511   if (strpbrk(wildspec,"]>:") != NULL) {
7512     if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7513         Safefree(unixwild);
7514         return 0;
7515     }
7516   }
7517   else {
7518     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7519     unixwild[VMS_MAXRSS-1] = 0;
7520   }
7521   Newx(unixified, VMS_MAXRSS, char);
7522   if (strpbrk(fspec,"]>:") != NULL) {
7523     if (do_tounixspec(fspec,unixified,0) == NULL) {
7524         Safefree(unixwild);
7525         Safefree(unixified);
7526         return 0;
7527     }
7528     else base = unixified;
7529     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7530      * check to see that final result fits into (isn't longer than) fspec */
7531     reslen = strlen(fspec);
7532   }
7533   else base = fspec;
7534
7535   /* No prefix or absolute path on wildcard, so nothing to remove */
7536   if (!*template || *template == '/') {
7537     Safefree(unixwild);
7538     if (base == fspec) {
7539         Safefree(unixified);
7540         return 1;
7541     }
7542     tmplen = strlen(unixified);
7543     if (tmplen > reslen) {
7544         Safefree(unixified);
7545         return 0;  /* not enough space */
7546     }
7547     /* Copy unixified resultant, including trailing NUL */
7548     memmove(fspec,unixified,tmplen+1);
7549     Safefree(unixified);
7550     return 1;
7551   }
7552
7553   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
7554   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7555     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7556     for (cp1 = end ;cp1 >= base; cp1--)
7557       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7558         { cp1++; break; }
7559     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7560     Safefree(unixified);
7561     Safefree(unixwild);
7562     return 1;
7563   }
7564   else {
7565     char *tpl, *lcres;
7566     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7567     int ells = 1, totells, segdirs, match;
7568     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7569                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7570
7571     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7572     totells = ells;
7573     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7574     Newx(tpl, VMS_MAXRSS, char);
7575     if (ellipsis == template && opts & 1) {
7576       /* Template begins with an ellipsis.  Since we can't tell how many
7577        * directory names at the front of the resultant to keep for an
7578        * arbitrary starting point, we arbitrarily choose the current
7579        * default directory as a starting point.  If it's there as a prefix,
7580        * clip it off.  If not, fall through and act as if the leading
7581        * ellipsis weren't there (i.e. return shortest possible path that
7582        * could match template).
7583        */
7584       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7585           Safefree(tpl);
7586           Safefree(unixified);
7587           Safefree(unixwild);
7588           return 0;
7589       }
7590       if (!decc_efs_case_preserve) {
7591         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7592           if (_tolower(*cp1) != _tolower(*cp2)) break;
7593       }
7594       segdirs = dirs - totells;  /* Min # of dirs we must have left */
7595       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7596       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7597         memmove(fspec,cp2+1,end - cp2);
7598         Safefree(unixified);
7599         Safefree(unixwild);
7600         Safefree(tpl);
7601         return 1;
7602       }
7603     }
7604     /* First off, back up over constant elements at end of path */
7605     if (dirs) {
7606       for (front = end ; front >= base; front--)
7607          if (*front == '/' && !dirs--) { front++; break; }
7608     }
7609     Newx(lcres, VMS_MAXRSS, char);
7610     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7611          cp1++,cp2++) {
7612             if (!decc_efs_case_preserve) {
7613                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
7614             }
7615             else {
7616                 *cp2 = *cp1;
7617             }
7618     }
7619     if (cp1 != '\0') {
7620         Safefree(unixified);
7621         Safefree(unixwild);
7622         Safefree(lcres);
7623         Safefree(tpl);
7624         return 0;  /* Path too long. */
7625     }
7626     lcend = cp2;
7627     *cp2 = '\0';  /* Pick up with memcpy later */
7628     lcfront = lcres + (front - base);
7629     /* Now skip over each ellipsis and try to match the path in front of it. */
7630     while (ells--) {
7631       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7632         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
7633             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
7634       if (cp1 < template) break; /* template started with an ellipsis */
7635       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7636         ellipsis = cp1; continue;
7637       }
7638       wilddsc.dsc$a_pointer = tpl;
7639       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7640       nextell = cp1;
7641       for (segdirs = 0, cp2 = tpl;
7642            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7643            cp1++, cp2++) {
7644          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7645          else {
7646             if (!decc_efs_case_preserve) {
7647               *cp2 = _tolower(*cp1);  /* else lowercase for match */
7648             }
7649             else {
7650               *cp2 = *cp1;  /* else preserve case for match */
7651             }
7652          }
7653          if (*cp2 == '/') segdirs++;
7654       }
7655       if (cp1 != ellipsis - 1) {
7656           Safefree(unixified);
7657           Safefree(unixwild);
7658           Safefree(lcres);
7659           Safefree(tpl);
7660           return 0; /* Path too long */
7661       }
7662       /* Back up at least as many dirs as in template before matching */
7663       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7664         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7665       for (match = 0; cp1 > lcres;) {
7666         resdsc.dsc$a_pointer = cp1;
7667         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7668           match++;
7669           if (match == 1) lcfront = cp1;
7670         }
7671         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7672       }
7673       if (!match) {
7674         Safefree(unixified);
7675         Safefree(unixwild);
7676         Safefree(lcres);
7677         Safefree(tpl);
7678         return 0;  /* Can't find prefix ??? */
7679       }
7680       if (match > 1 && opts & 1) {
7681         /* This ... wildcard could cover more than one set of dirs (i.e.
7682          * a set of similar dir names is repeated).  If the template
7683          * contains more than 1 ..., upstream elements could resolve the
7684          * ambiguity, but it's not worth a full backtracking setup here.
7685          * As a quick heuristic, clip off the current default directory
7686          * if it's present to find the trimmed spec, else use the
7687          * shortest string that this ... could cover.
7688          */
7689         char def[NAM$C_MAXRSS+1], *st;
7690
7691         if (getcwd(def, sizeof def,0) == NULL) {
7692             Safefree(unixified);
7693             Safefree(unixwild);
7694             Safefree(lcres);
7695             Safefree(tpl);
7696             return 0;
7697         }
7698         if (!decc_efs_case_preserve) {
7699           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7700             if (_tolower(*cp1) != _tolower(*cp2)) break;
7701         }
7702         segdirs = dirs - totells;  /* Min # of dirs we must have left */
7703         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7704         if (*cp1 == '\0' && *cp2 == '/') {
7705           memmove(fspec,cp2+1,end - cp2);
7706           Safefree(lcres);
7707           Safefree(unixified);
7708           Safefree(unixwild);
7709           Safefree(tpl);
7710           return 1;
7711         }
7712         /* Nope -- stick with lcfront from above and keep going. */
7713       }
7714     }
7715     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7716     Safefree(unixified);
7717     Safefree(unixwild);
7718     Safefree(lcres);
7719     Safefree(tpl);
7720     return 1;
7721     ellipsis = nextell;
7722   }
7723
7724 }  /* end of trim_unixpath() */
7725 /*}}}*/
7726
7727
7728 /*
7729  *  VMS readdir() routines.
7730  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7731  *
7732  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
7733  *  Minor modifications to original routines.
7734  */
7735
7736 /* readdir may have been redefined by reentr.h, so make sure we get
7737  * the local version for what we do here.
7738  */
7739 #ifdef readdir
7740 # undef readdir
7741 #endif
7742 #if !defined(PERL_IMPLICIT_CONTEXT)
7743 # define readdir Perl_readdir
7744 #else
7745 # define readdir(a) Perl_readdir(aTHX_ a)
7746 #endif
7747
7748     /* Number of elements in vms_versions array */
7749 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
7750
7751 /*
7752  *  Open a directory, return a handle for later use.
7753  */
7754 /*{{{ DIR *opendir(char*name) */
7755 DIR *
7756 Perl_opendir(pTHX_ const char *name)
7757 {
7758     DIR *dd;
7759     char *dir;
7760     Stat_t sb;
7761     int unix_flag;
7762
7763     unix_flag = 0;
7764     if (decc_efs_charset) {
7765         unix_flag = is_unix_filespec(name);
7766     }
7767
7768     Newx(dir, VMS_MAXRSS, char);
7769     if (do_tovmspath(name,dir,0) == NULL) {
7770       Safefree(dir);
7771       return NULL;
7772     }
7773     /* Check access before stat; otherwise stat does not
7774      * accurately report whether it's a directory.
7775      */
7776     if (!cando_by_name(S_IRUSR,0,dir)) {
7777       /* cando_by_name has already set errno */
7778       Safefree(dir);
7779       return NULL;
7780     }
7781     if (flex_stat(dir,&sb) == -1) return NULL;
7782     if (!S_ISDIR(sb.st_mode)) {
7783       Safefree(dir);
7784       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
7785       return NULL;
7786     }
7787     /* Get memory for the handle, and the pattern. */
7788     Newx(dd,1,DIR);
7789     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7790
7791     /* Fill in the fields; mainly playing with the descriptor. */
7792     sprintf(dd->pattern, "%s*.*",dir);
7793     Safefree(dir);
7794     dd->context = 0;
7795     dd->count = 0;
7796     dd->flags = 0;
7797     if (unix_flag)
7798         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
7799     dd->pat.dsc$a_pointer = dd->pattern;
7800     dd->pat.dsc$w_length = strlen(dd->pattern);
7801     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7802     dd->pat.dsc$b_class = DSC$K_CLASS_S;
7803 #if defined(USE_ITHREADS)
7804     Newx(dd->mutex,1,perl_mutex);
7805     MUTEX_INIT( (perl_mutex *) dd->mutex );
7806 #else
7807     dd->mutex = NULL;
7808 #endif
7809
7810     return dd;
7811 }  /* end of opendir() */
7812 /*}}}*/
7813
7814 /*
7815  *  Set the flag to indicate we want versions or not.
7816  */
7817 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7818 void
7819 vmsreaddirversions(DIR *dd, int flag)
7820 {
7821     if (flag)
7822         dd->flags |= PERL_VMSDIR_M_VERSIONS;
7823     else
7824         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
7825 }
7826 /*}}}*/
7827
7828 /*
7829  *  Free up an opened directory.
7830  */
7831 /*{{{ void closedir(DIR *dd)*/
7832 void
7833 Perl_closedir(DIR *dd)
7834 {
7835     int sts;
7836
7837     sts = lib$find_file_end(&dd->context);
7838     Safefree(dd->pattern);
7839 #if defined(USE_ITHREADS)
7840     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7841     Safefree(dd->mutex);
7842 #endif
7843     Safefree(dd);
7844 }
7845 /*}}}*/
7846
7847 /*
7848  *  Collect all the version numbers for the current file.
7849  */
7850 static void
7851 collectversions(pTHX_ DIR *dd)
7852 {
7853     struct dsc$descriptor_s     pat;
7854     struct dsc$descriptor_s     res;
7855     struct dirent *e;
7856     char *p, *text, *buff;
7857     int i;
7858     unsigned long context, tmpsts;
7859
7860     /* Convenient shorthand. */
7861     e = &dd->entry;
7862
7863     /* Add the version wildcard, ignoring the "*.*" put on before */
7864     i = strlen(dd->pattern);
7865     Newx(text,i + e->d_namlen + 3,char);
7866     strcpy(text, dd->pattern);
7867     sprintf(&text[i - 3], "%s;*", e->d_name);
7868
7869     /* Set up the pattern descriptor. */
7870     pat.dsc$a_pointer = text;
7871     pat.dsc$w_length = i + e->d_namlen - 1;
7872     pat.dsc$b_dtype = DSC$K_DTYPE_T;
7873     pat.dsc$b_class = DSC$K_CLASS_S;
7874
7875     /* Set up result descriptor. */
7876     Newx(buff, VMS_MAXRSS, char);
7877     res.dsc$a_pointer = buff;
7878     res.dsc$w_length = VMS_MAXRSS - 1;
7879     res.dsc$b_dtype = DSC$K_DTYPE_T;
7880     res.dsc$b_class = DSC$K_CLASS_S;
7881
7882     /* Read files, collecting versions. */
7883     for (context = 0, e->vms_verscount = 0;
7884          e->vms_verscount < VERSIZE(e);
7885          e->vms_verscount++) {
7886         unsigned long rsts;
7887         unsigned long flags = 0;
7888
7889 #ifdef VMS_LONGNAME_SUPPORT
7890         flags = LIB$M_FIL_LONG_NAMES
7891 #endif
7892         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
7893         if (tmpsts == RMS$_NMF || context == 0) break;
7894         _ckvmssts(tmpsts);
7895         buff[VMS_MAXRSS - 1] = '\0';
7896         if ((p = strchr(buff, ';')))
7897             e->vms_versions[e->vms_verscount] = atoi(p + 1);
7898         else
7899             e->vms_versions[e->vms_verscount] = -1;
7900     }
7901
7902     _ckvmssts(lib$find_file_end(&context));
7903     Safefree(text);
7904     Safefree(buff);
7905
7906 }  /* end of collectversions() */
7907
7908 /*
7909  *  Read the next entry from the directory.
7910  */
7911 /*{{{ struct dirent *readdir(DIR *dd)*/
7912 struct dirent *
7913 Perl_readdir(pTHX_ DIR *dd)
7914 {
7915     struct dsc$descriptor_s     res;
7916     char *p, *buff;
7917     unsigned long int tmpsts;
7918     unsigned long rsts;
7919     unsigned long flags = 0;
7920     const char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7921     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7922
7923     /* Set up result descriptor, and get next file. */
7924     Newx(buff, VMS_MAXRSS, char);
7925     res.dsc$a_pointer = buff;
7926     res.dsc$w_length = VMS_MAXRSS - 1;
7927     res.dsc$b_dtype = DSC$K_DTYPE_T;
7928     res.dsc$b_class = DSC$K_CLASS_S;
7929
7930 #ifdef VMS_LONGNAME_SUPPORT
7931     flags = LIB$M_FIL_LONG_NAMES
7932 #endif
7933
7934     tmpsts = lib$find_file
7935         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
7936     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
7937     if (!(tmpsts & 1)) {
7938       set_vaxc_errno(tmpsts);
7939       switch (tmpsts) {
7940         case RMS$_PRV:
7941           set_errno(EACCES); break;
7942         case RMS$_DEV:
7943           set_errno(ENODEV); break;
7944         case RMS$_DIR:
7945           set_errno(ENOTDIR); break;
7946         case RMS$_FNF: case RMS$_DNF:
7947           set_errno(ENOENT); break;
7948         default:
7949           set_errno(EVMSERR);
7950       }
7951       Safefree(buff);
7952       return NULL;
7953     }
7954     dd->count++;
7955     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
7956     if (!decc_efs_case_preserve) {
7957       buff[VMS_MAXRSS - 1] = '\0';
7958       for (p = buff; *p; p++) *p = _tolower(*p);
7959     }
7960     else {
7961       /* we don't want to force to lowercase, just null terminate */
7962       buff[res.dsc$w_length] = '\0';
7963     }
7964     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
7965     *p = '\0';
7966
7967     /* Skip any directory component and just copy the name. */
7968     sts = vms_split_path
7969        (buff,
7970         &v_spec,
7971         &v_len,
7972         &r_spec,
7973         &r_len,
7974         &d_spec,
7975         &d_len,
7976         &n_spec,
7977         &n_len,
7978         &e_spec,
7979         &e_len,
7980         &vs_spec,
7981         &vs_len);
7982
7983     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
7984     dd->entry.d_name[n_len + e_len] = '\0';
7985     dd->entry.d_namlen = strlen(dd->entry.d_name);
7986
7987     /* Convert the filename to UNIX format if needed */
7988     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
7989
7990         /* Translate the encoded characters. */
7991         /* Fixme: unicode handling could result in embedded 0 characters */
7992         if (strchr(dd->entry.d_name, '^') != NULL) {
7993             char new_name[256];
7994             char * q;
7995             int cnt;
7996             p = dd->entry.d_name;
7997             q = new_name;
7998             while (*p != 0) {
7999                 if ((*p == '.') && (p[1] == 0) && decc_readdir_dropdotnotype) {
8000                     /* Normally trailing dots should be dropped */
8001                     p++;
8002                 }
8003                 else {
8004                     int x, y;
8005                     x = copy_expand_vms_filename_escape(q, p, &y);
8006                     p += x;
8007                     q += y;
8008                     /* fix-me */
8009                     /* if y > 1, then this is a wide file specification */
8010                     /* Wide file specifications need to be passed in Perl */
8011                     /* counted strings apparently with a unicode flag */
8012                 }
8013             }
8014             *q = 0;
8015             strcpy(dd->entry.d_name, new_name);
8016         }
8017         else {
8018             /* Remove a trailing "." if present and not preceded by a ^ */
8019             if ((dd->entry.d_name[dd->entry.d_namlen-1] == '.') &&
8020                   decc_readdir_dropdotnotype) {
8021                 dd->entry.d_namlen--;
8022                 dd->entry.d_name[dd->entry.d_namlen] == 0;
8023             }
8024         }
8025     }
8026
8027     dd->entry.vms_verscount = 0;
8028     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8029     Safefree(buff);
8030     return &dd->entry;
8031
8032 }  /* end of readdir() */
8033 /*}}}*/
8034
8035 /*
8036  *  Read the next entry from the directory -- thread-safe version.
8037  */
8038 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8039 int
8040 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8041 {
8042     int retval;
8043
8044     MUTEX_LOCK( (perl_mutex *) dd->mutex );
8045
8046     entry = readdir(dd);
8047     *result = entry;
8048     retval = ( *result == NULL ? errno : 0 );
8049
8050     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8051
8052     return retval;
8053
8054 }  /* end of readdir_r() */
8055 /*}}}*/
8056
8057 /*
8058  *  Return something that can be used in a seekdir later.
8059  */
8060 /*{{{ long telldir(DIR *dd)*/
8061 long
8062 Perl_telldir(DIR *dd)
8063 {
8064     return dd->count;
8065 }
8066 /*}}}*/
8067
8068 /*
8069  *  Return to a spot where we used to be.  Brute force.
8070  */
8071 /*{{{ void seekdir(DIR *dd,long count)*/
8072 void
8073 Perl_seekdir(pTHX_ DIR *dd, long count)
8074 {
8075     int old_flags;
8076
8077     /* If we haven't done anything yet... */
8078     if (dd->count == 0)
8079         return;
8080
8081     /* Remember some state, and clear it. */
8082     old_flags = dd->flags;
8083     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8084     _ckvmssts(lib$find_file_end(&dd->context));
8085     dd->context = 0;
8086
8087     /* The increment is in readdir(). */
8088     for (dd->count = 0; dd->count < count; )
8089         readdir(dd);
8090
8091     dd->flags = old_flags;
8092
8093 }  /* end of seekdir() */
8094 /*}}}*/
8095
8096 /* VMS subprocess management
8097  *
8098  * my_vfork() - just a vfork(), after setting a flag to record that
8099  * the current script is trying a Unix-style fork/exec.
8100  *
8101  * vms_do_aexec() and vms_do_exec() are called in response to the
8102  * perl 'exec' function.  If this follows a vfork call, then they
8103  * call out the regular perl routines in doio.c which do an
8104  * execvp (for those who really want to try this under VMS).
8105  * Otherwise, they do exactly what the perl docs say exec should
8106  * do - terminate the current script and invoke a new command
8107  * (See below for notes on command syntax.)
8108  *
8109  * do_aspawn() and do_spawn() implement the VMS side of the perl
8110  * 'system' function.
8111  *
8112  * Note on command arguments to perl 'exec' and 'system': When handled
8113  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8114  * are concatenated to form a DCL command string.  If the first arg
8115  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8116  * the command string is handed off to DCL directly.  Otherwise,
8117  * the first token of the command is taken as the filespec of an image
8118  * to run.  The filespec is expanded using a default type of '.EXE' and
8119  * the process defaults for device, directory, etc., and if found, the resultant
8120  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8121  * the command string as parameters.  This is perhaps a bit complicated,
8122  * but I hope it will form a happy medium between what VMS folks expect
8123  * from lib$spawn and what Unix folks expect from exec.
8124  */
8125
8126 static int vfork_called;
8127
8128 /*{{{int my_vfork()*/
8129 int
8130 my_vfork()
8131 {
8132   vfork_called++;
8133   return vfork();
8134 }
8135 /*}}}*/
8136
8137
8138 static void
8139 vms_execfree(struct dsc$descriptor_s *vmscmd)
8140 {
8141   if (vmscmd) {
8142       if (vmscmd->dsc$a_pointer) {
8143           Safefree(vmscmd->dsc$a_pointer);
8144       }
8145       Safefree(vmscmd);
8146   }
8147 }
8148
8149 static char *
8150 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8151 {
8152   char *junk, *tmps = Nullch;
8153   register size_t cmdlen = 0;
8154   size_t rlen;
8155   register SV **idx;
8156   STRLEN n_a;
8157
8158   idx = mark;
8159   if (really) {
8160     tmps = SvPV(really,rlen);
8161     if (*tmps) {
8162       cmdlen += rlen + 1;
8163       idx++;
8164     }
8165   }
8166
8167   for (idx++; idx <= sp; idx++) {
8168     if (*idx) {
8169       junk = SvPVx(*idx,rlen);
8170       cmdlen += rlen ? rlen + 1 : 0;
8171     }
8172   }
8173   Newx(PL_Cmd,cmdlen+1,char);
8174
8175   if (tmps && *tmps) {
8176     strcpy(PL_Cmd,tmps);
8177     mark++;
8178   }
8179   else *PL_Cmd = '\0';
8180   while (++mark <= sp) {
8181     if (*mark) {
8182       char *s = SvPVx(*mark,n_a);
8183       if (!*s) continue;
8184       if (*PL_Cmd) strcat(PL_Cmd," ");
8185       strcat(PL_Cmd,s);
8186     }
8187   }
8188   return PL_Cmd;
8189
8190 }  /* end of setup_argstr() */
8191
8192
8193 static unsigned long int
8194 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8195                    struct dsc$descriptor_s **pvmscmd)
8196 {
8197   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8198   char image_name[NAM$C_MAXRSS+1];
8199   char image_argv[NAM$C_MAXRSS+1];
8200   $DESCRIPTOR(defdsc,".EXE");
8201   $DESCRIPTOR(defdsc2,".");
8202   $DESCRIPTOR(resdsc,resspec);
8203   struct dsc$descriptor_s *vmscmd;
8204   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8205   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8206   register char *s, *rest, *cp, *wordbreak;
8207   char * cmd;
8208   int cmdlen;
8209   register int isdcl;
8210
8211   Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
8212
8213   /* Make a copy for modification */
8214   cmdlen = strlen(incmd);
8215   Newx(cmd, cmdlen+1, char);
8216   strncpy(cmd, incmd, cmdlen);
8217   cmd[cmdlen] = 0;
8218   image_name[0] = 0;
8219   image_argv[0] = 0;
8220
8221   vmscmd->dsc$a_pointer = NULL;
8222   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
8223   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
8224   vmscmd->dsc$w_length = 0;
8225   if (pvmscmd) *pvmscmd = vmscmd;
8226
8227   if (suggest_quote) *suggest_quote = 0;
8228
8229   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8230     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
8231     Safefree(cmd);
8232   }
8233
8234   s = cmd;
8235
8236   while (*s && isspace(*s)) s++;
8237
8238   if (*s == '@' || *s == '$') {
8239     vmsspec[0] = *s;  rest = s + 1;
8240     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8241   }
8242   else { cp = vmsspec; rest = s; }
8243   if (*rest == '.' || *rest == '/') {
8244     char *cp2;
8245     for (cp2 = resspec;
8246          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8247          rest++, cp2++) *cp2 = *rest;
8248     *cp2 = '\0';
8249     if (do_tovmsspec(resspec,cp,0)) {
8250       s = vmsspec;
8251       if (*rest) {
8252         for (cp2 = vmsspec + strlen(vmsspec);
8253              *rest && cp2 - vmsspec < sizeof vmsspec;
8254              rest++, cp2++) *cp2 = *rest;
8255         *cp2 = '\0';
8256       }
8257     }
8258   }
8259   /* Intuit whether verb (first word of cmd) is a DCL command:
8260    *   - if first nonspace char is '@', it's a DCL indirection
8261    * otherwise
8262    *   - if verb contains a filespec separator, it's not a DCL command
8263    *   - if it doesn't, caller tells us whether to default to a DCL
8264    *     command, or to a local image unless told it's DCL (by leading '$')
8265    */
8266   if (*s == '@') {
8267       isdcl = 1;
8268       if (suggest_quote) *suggest_quote = 1;
8269   } else {
8270     register char *filespec = strpbrk(s,":<[.;");
8271     rest = wordbreak = strpbrk(s," \"\t/");
8272     if (!wordbreak) wordbreak = s + strlen(s);
8273     if (*s == '$') check_img = 0;
8274     if (filespec && (filespec < wordbreak)) isdcl = 0;
8275     else isdcl = !check_img;
8276   }
8277
8278   if (!isdcl) {
8279     imgdsc.dsc$a_pointer = s;
8280     imgdsc.dsc$w_length = wordbreak - s;
8281     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
8282     if (!(retsts&1)) {
8283         _ckvmssts(lib$find_file_end(&cxt));
8284         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
8285       if (!(retsts & 1) && *s == '$') {
8286         _ckvmssts(lib$find_file_end(&cxt));
8287         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8288         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
8289         if (!(retsts&1)) {
8290           _ckvmssts(lib$find_file_end(&cxt));
8291           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
8292         }
8293       }
8294     }
8295     _ckvmssts(lib$find_file_end(&cxt));
8296
8297     if (retsts & 1) {
8298       FILE *fp;
8299       s = resspec;
8300       while (*s && !isspace(*s)) s++;
8301       *s = '\0';
8302
8303       /* check that it's really not DCL with no file extension */
8304       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8305       if (fp) {
8306         char b[256] = {0,0,0,0};
8307         read(fileno(fp), b, 256);
8308         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
8309         if (isdcl) {
8310           int shebang_len;
8311
8312           /* Check for script */
8313           shebang_len = 0;
8314           if ((b[0] == '#') && (b[1] == '!'))
8315              shebang_len = 2;
8316 #ifdef ALTERNATE_SHEBANG
8317           else {
8318             shebang_len = strlen(ALTERNATE_SHEBANG);
8319             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
8320               char * perlstr;
8321                 perlstr = strstr("perl",b);
8322                 if (perlstr == NULL)
8323                   shebang_len = 0;
8324             }
8325             else
8326               shebang_len = 0;
8327           }
8328 #endif
8329
8330           if (shebang_len > 0) {
8331           int i;
8332           int j;
8333           char tmpspec[NAM$C_MAXRSS + 1];
8334
8335             i = shebang_len;
8336              /* Image is following after white space */
8337             /*--------------------------------------*/
8338             while (isprint(b[i]) && isspace(b[i]))
8339                 i++;
8340
8341             j = 0;
8342             while (isprint(b[i]) && !isspace(b[i])) {
8343                 tmpspec[j++] = b[i++];
8344                 if (j >= NAM$C_MAXRSS)
8345                    break;
8346             }
8347             tmpspec[j] = '\0';
8348
8349              /* There may be some default parameters to the image */
8350             /*---------------------------------------------------*/
8351             j = 0;
8352             while (isprint(b[i])) {
8353                 image_argv[j++] = b[i++];
8354                 if (j >= NAM$C_MAXRSS)
8355                    break;
8356             }
8357             while ((j > 0) && !isprint(image_argv[j-1]))
8358                 j--;
8359             image_argv[j] = 0;
8360
8361             /* It will need to be converted to VMS format and validated */
8362             if (tmpspec[0] != '\0') {
8363               char * iname;
8364
8365                /* Try to find the exact program requested to be run */
8366               /*---------------------------------------------------*/
8367               iname = do_rmsexpand
8368                   (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8369               if (iname != NULL) {
8370                 if (cando_by_name(S_IXUSR,0,image_name)) {
8371                   /* MCR prefix needed */
8372                   isdcl = 0;
8373                 }
8374                 else {
8375                    /* Try again with a null type */
8376                   /*----------------------------*/
8377                   iname = do_rmsexpand
8378                     (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8379                   if (iname != NULL) {
8380                     if (cando_by_name(S_IXUSR,0,image_name)) {
8381                       /* MCR prefix needed */
8382                       isdcl = 0;
8383                     }
8384                   }
8385                 }
8386
8387                  /* Did we find the image to run the script? */
8388                 /*------------------------------------------*/
8389                 if (isdcl) {
8390                   char *tchr;
8391
8392                    /* Assume DCL or foreign command exists */
8393                   /*--------------------------------------*/
8394                   tchr = strrchr(tmpspec, '/');
8395                   if (tchr != NULL) {
8396                     tchr++;
8397                   }
8398                   else {
8399                     tchr = tmpspec;
8400                   }
8401                   strcpy(image_name, tchr);
8402                 }
8403               }
8404             }
8405           }
8406         }
8407         fclose(fp);
8408       }
8409       if (check_img && isdcl) return RMS$_FNF;
8410
8411       if (cando_by_name(S_IXUSR,0,resspec)) {
8412         Newx(vmscmd->dsc$a_pointer, MAX_DCL_LINE_LENGTH ,char);
8413         if (!isdcl) {
8414             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8415             if (image_name[0] != 0) {
8416                 strcat(vmscmd->dsc$a_pointer, image_name);
8417                 strcat(vmscmd->dsc$a_pointer, " ");
8418             }
8419         } else if (image_name[0] != 0) {
8420             strcpy(vmscmd->dsc$a_pointer, image_name);
8421             strcat(vmscmd->dsc$a_pointer, " ");
8422         } else {
8423             strcpy(vmscmd->dsc$a_pointer,"@");
8424         }
8425         if (suggest_quote) *suggest_quote = 1;
8426
8427         /* If there is an image name, use original command */
8428         if (image_name[0] == 0)
8429             strcat(vmscmd->dsc$a_pointer,resspec);
8430         else {
8431             rest = cmd;
8432             while (*rest && isspace(*rest)) rest++;
8433         }
8434
8435         if (image_argv[0] != 0) {
8436           strcat(vmscmd->dsc$a_pointer,image_argv);
8437           strcat(vmscmd->dsc$a_pointer, " ");
8438         }
8439         if (rest) {
8440            int rest_len;
8441            int vmscmd_len;
8442
8443            rest_len = strlen(rest);
8444            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8445            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8446               strcat(vmscmd->dsc$a_pointer,rest);
8447            else
8448              retsts = CLI$_BUFOVF;
8449         }
8450         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8451         Safefree(cmd);
8452         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8453       }
8454       else retsts = RMS$_PRV;
8455     }
8456   }
8457   /* It's either a DCL command or we couldn't find a suitable image */
8458   vmscmd->dsc$w_length = strlen(cmd);
8459 /*  if (cmd == PL_Cmd) {
8460       vmscmd->dsc$a_pointer = PL_Cmd;
8461       if (suggest_quote) *suggest_quote = 1;
8462   }
8463   else  */
8464       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
8465
8466   Safefree(cmd);
8467
8468   /* check if it's a symbol (for quoting purposes) */
8469   if (suggest_quote && !*suggest_quote) {
8470     int iss;
8471     char equiv[LNM$C_NAMLENGTH];
8472     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8473     eqvdsc.dsc$a_pointer = equiv;
8474
8475     iss = lib$get_symbol(vmscmd,&eqvdsc);
8476     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8477   }
8478   if (!(retsts & 1)) {
8479     /* just hand off status values likely to be due to user error */
8480     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8481         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8482        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8483     else { _ckvmssts(retsts); }
8484   }
8485
8486   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8487
8488 }  /* end of setup_cmddsc() */
8489
8490
8491 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8492 bool
8493 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8494 {
8495   if (sp > mark) {
8496     if (vfork_called) {           /* this follows a vfork - act Unixish */
8497       vfork_called--;
8498       if (vfork_called < 0) {
8499         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8500         vfork_called = 0;
8501       }
8502       else return do_aexec(really,mark,sp);
8503     }
8504                                            /* no vfork - act VMSish */
8505     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
8506
8507   }
8508
8509   return FALSE;
8510 }  /* end of vms_do_aexec() */
8511 /*}}}*/
8512
8513 /* {{{bool vms_do_exec(char *cmd) */
8514 bool
8515 Perl_vms_do_exec(pTHX_ const char *cmd)
8516 {
8517   struct dsc$descriptor_s *vmscmd;
8518
8519   if (vfork_called) {             /* this follows a vfork - act Unixish */
8520     vfork_called--;
8521     if (vfork_called < 0) {
8522       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8523       vfork_called = 0;
8524     }
8525     else return do_exec(cmd);
8526   }
8527
8528   {                               /* no vfork - act VMSish */
8529     unsigned long int retsts;
8530
8531     TAINT_ENV();
8532     TAINT_PROPER("exec");
8533     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8534       retsts = lib$do_command(vmscmd);
8535
8536     switch (retsts) {
8537       case RMS$_FNF: case RMS$_DNF:
8538         set_errno(ENOENT); break;
8539       case RMS$_DIR:
8540         set_errno(ENOTDIR); break;
8541       case RMS$_DEV:
8542         set_errno(ENODEV); break;
8543       case RMS$_PRV:
8544         set_errno(EACCES); break;
8545       case RMS$_SYN:
8546         set_errno(EINVAL); break;
8547       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8548         set_errno(E2BIG); break;
8549       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8550         _ckvmssts(retsts); /* fall through */
8551       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8552         set_errno(EVMSERR);
8553     }
8554     set_vaxc_errno(retsts);
8555     if (ckWARN(WARN_EXEC)) {
8556       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8557              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8558     }
8559     vms_execfree(vmscmd);
8560   }
8561
8562   return FALSE;
8563
8564 }  /* end of vms_do_exec() */
8565 /*}}}*/
8566
8567 unsigned long int Perl_do_spawn(pTHX_ const char *);
8568
8569 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8570 unsigned long int
8571 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8572 {
8573   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
8574
8575   return SS$_ABORT;
8576 }  /* end of do_aspawn() */
8577 /*}}}*/
8578
8579 /* {{{unsigned long int do_spawn(char *cmd) */
8580 unsigned long int
8581 Perl_do_spawn(pTHX_ const char *cmd)
8582 {
8583   unsigned long int sts, substs;
8584
8585   TAINT_ENV();
8586   TAINT_PROPER("spawn");
8587   if (!cmd || !*cmd) {
8588     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8589     if (!(sts & 1)) {
8590       switch (sts) {
8591         case RMS$_FNF:  case RMS$_DNF:
8592           set_errno(ENOENT); break;
8593         case RMS$_DIR:
8594           set_errno(ENOTDIR); break;
8595         case RMS$_DEV:
8596           set_errno(ENODEV); break;
8597         case RMS$_PRV:
8598           set_errno(EACCES); break;
8599         case RMS$_SYN:
8600           set_errno(EINVAL); break;
8601         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8602           set_errno(E2BIG); break;
8603         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8604           _ckvmssts(sts); /* fall through */
8605         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8606           set_errno(EVMSERR);
8607       }
8608       set_vaxc_errno(sts);
8609       if (ckWARN(WARN_EXEC)) {
8610         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8611                     Strerror(errno));
8612       }
8613     }
8614     sts = substs;
8615   }
8616   else {
8617     PerlIO * fp;
8618     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8619     if (fp != NULL)
8620       my_pclose(fp);
8621   }
8622   return sts;
8623 }  /* end of do_spawn() */
8624 /*}}}*/
8625
8626
8627 static unsigned int *sockflags, sockflagsize;
8628
8629 /*
8630  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8631  * routines found in some versions of the CRTL can't deal with sockets.
8632  * We don't shim the other file open routines since a socket isn't
8633  * likely to be opened by a name.
8634  */
8635 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8636 FILE *my_fdopen(int fd, const char *mode)
8637 {
8638   FILE *fp = fdopen(fd, mode);
8639
8640   if (fp) {
8641     unsigned int fdoff = fd / sizeof(unsigned int);
8642     Stat_t sbuf; /* native stat; we don't need flex_stat */
8643     if (!sockflagsize || fdoff > sockflagsize) {
8644       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
8645       else           Newx  (sockflags,fdoff+2,unsigned int);
8646       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8647       sockflagsize = fdoff + 2;
8648     }
8649     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8650       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8651   }
8652   return fp;
8653
8654 }
8655 /*}}}*/
8656
8657
8658 /*
8659  * Clear the corresponding bit when the (possibly) socket stream is closed.
8660  * There still a small hole: we miss an implicit close which might occur
8661  * via freopen().  >> Todo
8662  */
8663 /*{{{ int my_fclose(FILE *fp)*/
8664 int my_fclose(FILE *fp) {
8665   if (fp) {
8666     unsigned int fd = fileno(fp);
8667     unsigned int fdoff = fd / sizeof(unsigned int);
8668
8669     if (sockflagsize && fdoff <= sockflagsize)
8670       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8671   }
8672   return fclose(fp);
8673 }
8674 /*}}}*/
8675
8676
8677 /*
8678  * A simple fwrite replacement which outputs itmsz*nitm chars without
8679  * introducing record boundaries every itmsz chars.
8680  * We are using fputs, which depends on a terminating null.  We may
8681  * well be writing binary data, so we need to accommodate not only
8682  * data with nulls sprinkled in the middle but also data with no null
8683  * byte at the end.
8684  */
8685 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8686 int
8687 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8688 {
8689   register char *cp, *end, *cpd, *data;
8690   register unsigned int fd = fileno(dest);
8691   register unsigned int fdoff = fd / sizeof(unsigned int);
8692   int retval;
8693   int bufsize = itmsz * nitm + 1;
8694
8695   if (fdoff < sockflagsize &&
8696       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8697     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8698     return nitm;
8699   }
8700
8701   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8702   memcpy( data, src, itmsz*nitm );
8703   data[itmsz*nitm] = '\0';
8704
8705   end = data + itmsz * nitm;
8706   retval = (int) nitm; /* on success return # items written */
8707
8708   cpd = data;
8709   while (cpd <= end) {
8710     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8711     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8712     if (cp < end)
8713       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8714     cpd = cp + 1;
8715   }
8716
8717   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8718   return retval;
8719
8720 }  /* end of my_fwrite() */
8721 /*}}}*/
8722
8723 /*{{{ int my_flush(FILE *fp)*/
8724 int
8725 Perl_my_flush(pTHX_ FILE *fp)
8726 {
8727     int res;
8728     if ((res = fflush(fp)) == 0 && fp) {
8729 #ifdef VMS_DO_SOCKETS
8730         Stat_t s;
8731         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8732 #endif
8733             res = fsync(fileno(fp));
8734     }
8735 /*
8736  * If the flush succeeded but set end-of-file, we need to clear
8737  * the error because our caller may check ferror().  BTW, this
8738  * probably means we just flushed an empty file.
8739  */
8740     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8741
8742     return res;
8743 }
8744 /*}}}*/
8745
8746 /*
8747  * Here are replacements for the following Unix routines in the VMS environment:
8748  *      getpwuid    Get information for a particular UIC or UID
8749  *      getpwnam    Get information for a named user
8750  *      getpwent    Get information for each user in the rights database
8751  *      setpwent    Reset search to the start of the rights database
8752  *      endpwent    Finish searching for users in the rights database
8753  *
8754  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8755  * (defined in pwd.h), which contains the following fields:-
8756  *      struct passwd {
8757  *              char        *pw_name;    Username (in lower case)
8758  *              char        *pw_passwd;  Hashed password
8759  *              unsigned int pw_uid;     UIC
8760  *              unsigned int pw_gid;     UIC group  number
8761  *              char        *pw_unixdir; Default device/directory (VMS-style)
8762  *              char        *pw_gecos;   Owner name
8763  *              char        *pw_dir;     Default device/directory (Unix-style)
8764  *              char        *pw_shell;   Default CLI name (eg. DCL)
8765  *      };
8766  * If the specified user does not exist, getpwuid and getpwnam return NULL.
8767  *
8768  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8769  * not the UIC member number (eg. what's returned by getuid()),
8770  * getpwuid() can accept either as input (if uid is specified, the caller's
8771  * UIC group is used), though it won't recognise gid=0.
8772  *
8773  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8774  * information about other users in your group or in other groups, respectively.
8775  * If the required privilege is not available, then these routines fill only
8776  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8777  * string).
8778  *
8779  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8780  */
8781
8782 /* sizes of various UAF record fields */
8783 #define UAI$S_USERNAME 12
8784 #define UAI$S_IDENT    31
8785 #define UAI$S_OWNER    31
8786 #define UAI$S_DEFDEV   31
8787 #define UAI$S_DEFDIR   63
8788 #define UAI$S_DEFCLI   31
8789 #define UAI$S_PWD       8
8790
8791 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
8792                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8793                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
8794
8795 static char __empty[]= "";
8796 static struct passwd __passwd_empty=
8797     {(char *) __empty, (char *) __empty, 0, 0,
8798      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8799 static int contxt= 0;
8800 static struct passwd __pwdcache;
8801 static char __pw_namecache[UAI$S_IDENT+1];
8802
8803 /*
8804  * This routine does most of the work extracting the user information.
8805  */
8806 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8807 {
8808     static struct {
8809         unsigned char length;
8810         char pw_gecos[UAI$S_OWNER+1];
8811     } owner;
8812     static union uicdef uic;
8813     static struct {
8814         unsigned char length;
8815         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8816     } defdev;
8817     static struct {
8818         unsigned char length;
8819         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8820     } defdir;
8821     static struct {
8822         unsigned char length;
8823         char pw_shell[UAI$S_DEFCLI+1];
8824     } defcli;
8825     static char pw_passwd[UAI$S_PWD+1];
8826
8827     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8828     struct dsc$descriptor_s name_desc;
8829     unsigned long int sts;
8830
8831     static struct itmlst_3 itmlst[]= {
8832         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
8833         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
8834         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
8835         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
8836         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
8837         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
8838         {0,                0,           NULL,    NULL}};
8839
8840     name_desc.dsc$w_length=  strlen(name);
8841     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8842     name_desc.dsc$b_class=   DSC$K_CLASS_S;
8843     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8844
8845 /*  Note that sys$getuai returns many fields as counted strings. */
8846     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8847     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8848       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8849     }
8850     else { _ckvmssts(sts); }
8851     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
8852
8853     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
8854     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8855     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8856     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8857     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8858     owner.pw_gecos[lowner]=            '\0';
8859     defdev.pw_dir[ldefdev+ldefdir]= '\0';
8860     defcli.pw_shell[ldefcli]=          '\0';
8861     if (valid_uic(uic)) {
8862         pwd->pw_uid= uic.uic$l_uic;
8863         pwd->pw_gid= uic.uic$v_group;
8864     }
8865     else
8866       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8867     pwd->pw_passwd=  pw_passwd;
8868     pwd->pw_gecos=   owner.pw_gecos;
8869     pwd->pw_dir=     defdev.pw_dir;
8870     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8871     pwd->pw_shell=   defcli.pw_shell;
8872     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8873         int ldir;
8874         ldir= strlen(pwd->pw_unixdir) - 1;
8875         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8876     }
8877     else
8878         strcpy(pwd->pw_unixdir, pwd->pw_dir);
8879     if (!decc_efs_case_preserve)
8880         __mystrtolower(pwd->pw_unixdir);
8881     return 1;
8882 }
8883
8884 /*
8885  * Get information for a named user.
8886 */
8887 /*{{{struct passwd *getpwnam(char *name)*/
8888 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8889 {
8890     struct dsc$descriptor_s name_desc;
8891     union uicdef uic;
8892     unsigned long int status, sts;
8893
8894     __pwdcache = __passwd_empty;
8895     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8896       /* We still may be able to determine pw_uid and pw_gid */
8897       name_desc.dsc$w_length=  strlen(name);
8898       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8899       name_desc.dsc$b_class=   DSC$K_CLASS_S;
8900       name_desc.dsc$a_pointer= (char *) name;
8901       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
8902         __pwdcache.pw_uid= uic.uic$l_uic;
8903         __pwdcache.pw_gid= uic.uic$v_group;
8904       }
8905       else {
8906         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8907           set_vaxc_errno(sts);
8908           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
8909           return NULL;
8910         }
8911         else { _ckvmssts(sts); }
8912       }
8913     }
8914     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8915     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8916     __pwdcache.pw_name= __pw_namecache;
8917     return &__pwdcache;
8918 }  /* end of my_getpwnam() */
8919 /*}}}*/
8920
8921 /*
8922  * Get information for a particular UIC or UID.
8923  * Called by my_getpwent with uid=-1 to list all users.
8924 */
8925 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
8926 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
8927 {
8928     const $DESCRIPTOR(name_desc,__pw_namecache);
8929     unsigned short lname;
8930     union uicdef uic;
8931     unsigned long int status;
8932
8933     if (uid == (unsigned int) -1) {
8934       do {
8935         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
8936         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
8937           set_vaxc_errno(status);
8938           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8939           my_endpwent();
8940           return NULL;
8941         }
8942         else { _ckvmssts(status); }
8943       } while (!valid_uic (uic));
8944     }
8945     else {
8946       uic.uic$l_uic= uid;
8947       if (!uic.uic$v_group)
8948         uic.uic$v_group= PerlProc_getgid();
8949       if (valid_uic(uic))
8950         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
8951       else status = SS$_IVIDENT;
8952       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
8953           status == RMS$_PRV) {
8954         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8955         return NULL;
8956       }
8957       else { _ckvmssts(status); }
8958     }
8959     __pw_namecache[lname]= '\0';
8960     __mystrtolower(__pw_namecache);
8961
8962     __pwdcache = __passwd_empty;
8963     __pwdcache.pw_name = __pw_namecache;
8964
8965 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
8966     The identifier's value is usually the UIC, but it doesn't have to be,
8967     so if we can, we let fillpasswd update this. */
8968     __pwdcache.pw_uid =  uic.uic$l_uic;
8969     __pwdcache.pw_gid =  uic.uic$v_group;
8970
8971     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
8972     return &__pwdcache;
8973
8974 }  /* end of my_getpwuid() */
8975 /*}}}*/
8976
8977 /*
8978  * Get information for next user.
8979 */
8980 /*{{{struct passwd *my_getpwent()*/
8981 struct passwd *Perl_my_getpwent(pTHX)
8982 {
8983     return (my_getpwuid((unsigned int) -1));
8984 }
8985 /*}}}*/
8986
8987 /*
8988  * Finish searching rights database for users.
8989 */
8990 /*{{{void my_endpwent()*/
8991 void Perl_my_endpwent(pTHX)
8992 {
8993     if (contxt) {
8994       _ckvmssts(sys$finish_rdb(&contxt));
8995       contxt= 0;
8996     }
8997 }
8998 /*}}}*/
8999
9000 #ifdef HOMEGROWN_POSIX_SIGNALS
9001   /* Signal handling routines, pulled into the core from POSIX.xs.
9002    *
9003    * We need these for threads, so they've been rolled into the core,
9004    * rather than left in POSIX.xs.
9005    *
9006    * (DRS, Oct 23, 1997)
9007    */
9008
9009   /* sigset_t is atomic under VMS, so these routines are easy */
9010 /*{{{int my_sigemptyset(sigset_t *) */
9011 int my_sigemptyset(sigset_t *set) {
9012     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9013     *set = 0; return 0;
9014 }
9015 /*}}}*/
9016
9017
9018 /*{{{int my_sigfillset(sigset_t *)*/
9019 int my_sigfillset(sigset_t *set) {
9020     int i;
9021     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9022     for (i = 0; i < NSIG; i++) *set |= (1 << i);
9023     return 0;
9024 }
9025 /*}}}*/
9026
9027
9028 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9029 int my_sigaddset(sigset_t *set, int sig) {
9030     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9031     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9032     *set |= (1 << (sig - 1));
9033     return 0;
9034 }
9035 /*}}}*/
9036
9037
9038 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9039 int my_sigdelset(sigset_t *set, int sig) {
9040     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9041     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9042     *set &= ~(1 << (sig - 1));
9043     return 0;
9044 }
9045 /*}}}*/
9046
9047
9048 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9049 int my_sigismember(sigset_t *set, int sig) {
9050     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9051     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9052     return *set & (1 << (sig - 1));
9053 }
9054 /*}}}*/
9055
9056
9057 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9058 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9059     sigset_t tempmask;
9060
9061     /* If set and oset are both null, then things are badly wrong. Bail out. */
9062     if ((oset == NULL) && (set == NULL)) {
9063       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9064       return -1;
9065     }
9066
9067     /* If set's null, then we're just handling a fetch. */
9068     if (set == NULL) {
9069         tempmask = sigblock(0);
9070     }
9071     else {
9072       switch (how) {
9073       case SIG_SETMASK:
9074         tempmask = sigsetmask(*set);
9075         break;
9076       case SIG_BLOCK:
9077         tempmask = sigblock(*set);
9078         break;
9079       case SIG_UNBLOCK:
9080         tempmask = sigblock(0);
9081         sigsetmask(*oset & ~tempmask);
9082         break;
9083       default:
9084         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9085         return -1;
9086       }
9087     }
9088
9089     /* Did they pass us an oset? If so, stick our holding mask into it */
9090     if (oset)
9091       *oset = tempmask;
9092
9093     return 0;
9094 }
9095 /*}}}*/
9096 #endif  /* HOMEGROWN_POSIX_SIGNALS */
9097
9098
9099 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9100  * my_utime(), and flex_stat(), all of which operate on UTC unless
9101  * VMSISH_TIMES is true.
9102  */
9103 /* method used to handle UTC conversions:
9104  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
9105  */
9106 static int gmtime_emulation_type;
9107 /* number of secs to add to UTC POSIX-style time to get local time */
9108 static long int utc_offset_secs;
9109
9110 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9111  * in vmsish.h.  #undef them here so we can call the CRTL routines
9112  * directly.
9113  */
9114 #undef gmtime
9115 #undef localtime
9116 #undef time
9117
9118
9119 /*
9120  * DEC C previous to 6.0 corrupts the behavior of the /prefix
9121  * qualifier with the extern prefix pragma.  This provisional
9122  * hack circumvents this prefix pragma problem in previous
9123  * precompilers.
9124  */
9125 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9126 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9127 #    pragma __extern_prefix save
9128 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
9129 #    define gmtime decc$__utctz_gmtime
9130 #    define localtime decc$__utctz_localtime
9131 #    define time decc$__utc_time
9132 #    pragma __extern_prefix restore
9133
9134      struct tm *gmtime(), *localtime();
9135
9136 #  endif
9137 #endif
9138
9139
9140 static time_t toutc_dst(time_t loc) {
9141   struct tm *rsltmp;
9142
9143   if ((rsltmp = localtime(&loc)) == NULL) return -1;
9144   loc -= utc_offset_secs;
9145   if (rsltmp->tm_isdst) loc -= 3600;
9146   return loc;
9147 }
9148 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9149        ((gmtime_emulation_type || my_time(NULL)), \
9150        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9151        ((secs) - utc_offset_secs))))
9152
9153 static time_t toloc_dst(time_t utc) {
9154   struct tm *rsltmp;
9155
9156   utc += utc_offset_secs;
9157   if ((rsltmp = localtime(&utc)) == NULL) return -1;
9158   if (rsltmp->tm_isdst) utc += 3600;
9159   return utc;
9160 }
9161 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9162        ((gmtime_emulation_type || my_time(NULL)), \
9163        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9164        ((secs) + utc_offset_secs))))
9165
9166 #ifndef RTL_USES_UTC
9167 /*
9168
9169     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
9170         DST starts on 1st sun of april      at 02:00  std time
9171             ends on last sun of october     at 02:00  dst time
9172     see the UCX management command reference, SET CONFIG TIMEZONE
9173     for formatting info.
9174
9175     No, it's not as general as it should be, but then again, NOTHING
9176     will handle UK times in a sensible way.
9177 */
9178
9179
9180 /*
9181     parse the DST start/end info:
9182     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9183 */
9184
9185 static char *
9186 tz_parse_startend(char *s, struct tm *w, int *past)
9187 {
9188     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9189     int ly, dozjd, d, m, n, hour, min, sec, j, k;
9190     time_t g;
9191
9192     if (!s)    return 0;
9193     if (!w) return 0;
9194     if (!past) return 0;
9195
9196     ly = 0;
9197     if (w->tm_year % 4        == 0) ly = 1;
9198     if (w->tm_year % 100      == 0) ly = 0;
9199     if (w->tm_year+1900 % 400 == 0) ly = 1;
9200     if (ly) dinm[1]++;
9201
9202     dozjd = isdigit(*s);
9203     if (*s == 'J' || *s == 'j' || dozjd) {
9204         if (!dozjd && !isdigit(*++s)) return 0;
9205         d = *s++ - '0';
9206         if (isdigit(*s)) {
9207             d = d*10 + *s++ - '0';
9208             if (isdigit(*s)) {
9209                 d = d*10 + *s++ - '0';
9210             }
9211         }
9212         if (d == 0) return 0;
9213         if (d > 366) return 0;
9214         d--;
9215         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
9216         g = d * 86400;
9217         dozjd = 1;
9218     } else if (*s == 'M' || *s == 'm') {
9219         if (!isdigit(*++s)) return 0;
9220         m = *s++ - '0';
9221         if (isdigit(*s)) m = 10*m + *s++ - '0';
9222         if (*s != '.') return 0;
9223         if (!isdigit(*++s)) return 0;
9224         n = *s++ - '0';
9225         if (n < 1 || n > 5) return 0;
9226         if (*s != '.') return 0;
9227         if (!isdigit(*++s)) return 0;
9228         d = *s++ - '0';
9229         if (d > 6) return 0;
9230     }
9231
9232     if (*s == '/') {
9233         if (!isdigit(*++s)) return 0;
9234         hour = *s++ - '0';
9235         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9236         if (*s == ':') {
9237             if (!isdigit(*++s)) return 0;
9238             min = *s++ - '0';
9239             if (isdigit(*s)) min = 10*min + *s++ - '0';
9240             if (*s == ':') {
9241                 if (!isdigit(*++s)) return 0;
9242                 sec = *s++ - '0';
9243                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9244             }
9245         }
9246     } else {
9247         hour = 2;
9248         min = 0;
9249         sec = 0;
9250     }
9251
9252     if (dozjd) {
9253         if (w->tm_yday < d) goto before;
9254         if (w->tm_yday > d) goto after;
9255     } else {
9256         if (w->tm_mon+1 < m) goto before;
9257         if (w->tm_mon+1 > m) goto after;
9258
9259         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
9260         k = d - j; /* mday of first d */
9261         if (k <= 0) k += 7;
9262         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
9263         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9264         if (w->tm_mday < k) goto before;
9265         if (w->tm_mday > k) goto after;
9266     }
9267
9268     if (w->tm_hour < hour) goto before;
9269     if (w->tm_hour > hour) goto after;
9270     if (w->tm_min  < min)  goto before;
9271     if (w->tm_min  > min)  goto after;
9272     if (w->tm_sec  < sec)  goto before;
9273     goto after;
9274
9275 before:
9276     *past = 0;
9277     return s;
9278 after:
9279     *past = 1;
9280     return s;
9281 }
9282
9283
9284
9285
9286 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
9287
9288 static char *
9289 tz_parse_offset(char *s, int *offset)
9290 {
9291     int hour = 0, min = 0, sec = 0;
9292     int neg = 0;
9293     if (!s) return 0;
9294     if (!offset) return 0;
9295
9296     if (*s == '-') {neg++; s++;}
9297     if (*s == '+') s++;
9298     if (!isdigit(*s)) return 0;
9299     hour = *s++ - '0';
9300     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
9301     if (hour > 24) return 0;
9302     if (*s == ':') {
9303         if (!isdigit(*++s)) return 0;
9304         min = *s++ - '0';
9305         if (isdigit(*s)) min = min*10 + (*s++ - '0');
9306         if (min > 59) return 0;
9307         if (*s == ':') {
9308             if (!isdigit(*++s)) return 0;
9309             sec = *s++ - '0';
9310             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
9311             if (sec > 59) return 0;
9312         }
9313     }
9314
9315     *offset = (hour*60+min)*60 + sec;
9316     if (neg) *offset = -*offset;
9317     return s;
9318 }
9319
9320 /*
9321     input time is w, whatever type of time the CRTL localtime() uses.
9322     sets dst, the zone, and the gmtoff (seconds)
9323
9324     caches the value of TZ and UCX$TZ env variables; note that
9325     my_setenv looks for these and sets a flag if they're changed
9326     for efficiency.
9327
9328     We have to watch out for the "australian" case (dst starts in
9329     october, ends in april)...flagged by "reverse" and checked by
9330     scanning through the months of the previous year.
9331
9332 */
9333
9334 static int
9335 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
9336 {
9337     time_t when;
9338     struct tm *w2;
9339     char *s,*s2;
9340     char *dstzone, *tz, *s_start, *s_end;
9341     int std_off, dst_off, isdst;
9342     int y, dststart, dstend;
9343     static char envtz[1025];  /* longer than any logical, symbol, ... */
9344     static char ucxtz[1025];
9345     static char reversed = 0;
9346
9347     if (!w) return 0;
9348
9349     if (tz_updated) {
9350         tz_updated = 0;
9351         reversed = -1;  /* flag need to check  */
9352         envtz[0] = ucxtz[0] = '\0';
9353         tz = my_getenv("TZ",0);
9354         if (tz) strcpy(envtz, tz);
9355         tz = my_getenv("UCX$TZ",0);
9356         if (tz) strcpy(ucxtz, tz);
9357         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
9358     }
9359     tz = envtz;
9360     if (!*tz) tz = ucxtz;
9361
9362     s = tz;
9363     while (isalpha(*s)) s++;
9364     s = tz_parse_offset(s, &std_off);
9365     if (!s) return 0;
9366     if (!*s) {                  /* no DST, hurray we're done! */
9367         isdst = 0;
9368         goto done;
9369     }
9370
9371     dstzone = s;
9372     while (isalpha(*s)) s++;
9373     s2 = tz_parse_offset(s, &dst_off);
9374     if (s2) {
9375         s = s2;
9376     } else {
9377         dst_off = std_off - 3600;
9378     }
9379
9380     if (!*s) {      /* default dst start/end?? */
9381         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
9382             s = strchr(ucxtz,',');
9383         }
9384         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
9385     }
9386     if (*s != ',') return 0;
9387
9388     when = *w;
9389     when = _toutc(when);      /* convert to utc */
9390     when = when - std_off;    /* convert to pseudolocal time*/
9391
9392     w2 = localtime(&when);
9393     y = w2->tm_year;
9394     s_start = s+1;
9395     s = tz_parse_startend(s_start,w2,&dststart);
9396     if (!s) return 0;
9397     if (*s != ',') return 0;
9398
9399     when = *w;
9400     when = _toutc(when);      /* convert to utc */
9401     when = when - dst_off;    /* convert to pseudolocal time*/
9402     w2 = localtime(&when);
9403     if (w2->tm_year != y) {   /* spans a year, just check one time */
9404         when += dst_off - std_off;
9405         w2 = localtime(&when);
9406     }
9407     s_end = s+1;
9408     s = tz_parse_startend(s_end,w2,&dstend);
9409     if (!s) return 0;
9410
9411     if (reversed == -1) {  /* need to check if start later than end */
9412         int j, ds, de;
9413
9414         when = *w;
9415         if (when < 2*365*86400) {
9416             when += 2*365*86400;
9417         } else {
9418             when -= 365*86400;
9419         }
9420         w2 =localtime(&when);
9421         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
9422
9423         for (j = 0; j < 12; j++) {
9424             w2 =localtime(&when);
9425             tz_parse_startend(s_start,w2,&ds);
9426             tz_parse_startend(s_end,w2,&de);
9427             if (ds != de) break;
9428             when += 30*86400;
9429         }
9430         reversed = 0;
9431         if (de && !ds) reversed = 1;
9432     }
9433
9434     isdst = dststart && !dstend;
9435     if (reversed) isdst = dststart  || !dstend;
9436
9437 done:
9438     if (dst)    *dst = isdst;
9439     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9440     if (isdst)  tz = dstzone;
9441     if (zone) {
9442         while(isalpha(*tz))  *zone++ = *tz++;
9443         *zone = '\0';
9444     }
9445     return 1;
9446 }
9447
9448 #endif /* !RTL_USES_UTC */
9449
9450 /* my_time(), my_localtime(), my_gmtime()
9451  * By default traffic in UTC time values, using CRTL gmtime() or
9452  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9453  * Note: We need to use these functions even when the CRTL has working
9454  * UTC support, since they also handle C<use vmsish qw(times);>
9455  *
9456  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
9457  * Modified by Charles Bailey <bailey@newman.upenn.edu>
9458  */
9459
9460 /*{{{time_t my_time(time_t *timep)*/
9461 time_t Perl_my_time(pTHX_ time_t *timep)
9462 {
9463   time_t when;
9464   struct tm *tm_p;
9465
9466   if (gmtime_emulation_type == 0) {
9467     int dstnow;
9468     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
9469                               /* results of calls to gmtime() and localtime() */
9470                               /* for same &base */
9471
9472     gmtime_emulation_type++;
9473     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9474       char off[LNM$C_NAMLENGTH+1];;
9475
9476       gmtime_emulation_type++;
9477       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9478         gmtime_emulation_type++;
9479         utc_offset_secs = 0;
9480         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9481       }
9482       else { utc_offset_secs = atol(off); }
9483     }
9484     else { /* We've got a working gmtime() */
9485       struct tm gmt, local;
9486
9487       gmt = *tm_p;
9488       tm_p = localtime(&base);
9489       local = *tm_p;
9490       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
9491       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9492       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
9493       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
9494     }
9495   }
9496
9497   when = time(NULL);
9498 # ifdef VMSISH_TIME
9499 # ifdef RTL_USES_UTC
9500   if (VMSISH_TIME) when = _toloc(when);
9501 # else
9502   if (!VMSISH_TIME) when = _toutc(when);
9503 # endif
9504 # endif
9505   if (timep != NULL) *timep = when;
9506   return when;
9507
9508 }  /* end of my_time() */
9509 /*}}}*/
9510
9511
9512 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9513 struct tm *
9514 Perl_my_gmtime(pTHX_ const time_t *timep)
9515 {
9516   char *p;
9517   time_t when;
9518   struct tm *rsltmp;
9519
9520   if (timep == NULL) {
9521     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9522     return NULL;
9523   }
9524   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9525
9526   when = *timep;
9527 # ifdef VMSISH_TIME
9528   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9529 #  endif
9530 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
9531   return gmtime(&when);
9532 # else
9533   /* CRTL localtime() wants local time as input, so does no tz correction */
9534   rsltmp = localtime(&when);
9535   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
9536   return rsltmp;
9537 #endif
9538 }  /* end of my_gmtime() */
9539 /*}}}*/
9540
9541
9542 /*{{{struct tm *my_localtime(const time_t *timep)*/
9543 struct tm *
9544 Perl_my_localtime(pTHX_ const time_t *timep)
9545 {
9546   time_t when, whenutc;
9547   struct tm *rsltmp;
9548   int dst, offset;
9549
9550   if (timep == NULL) {
9551     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9552     return NULL;
9553   }
9554   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
9555   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9556
9557   when = *timep;
9558 # ifdef RTL_USES_UTC
9559 # ifdef VMSISH_TIME
9560   if (VMSISH_TIME) when = _toutc(when);
9561 # endif
9562   /* CRTL localtime() wants UTC as input, does tz correction itself */
9563   return localtime(&when);
9564
9565 # else /* !RTL_USES_UTC */
9566   whenutc = when;
9567 # ifdef VMSISH_TIME
9568   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
9569   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
9570 # endif
9571   dst = -1;
9572 #ifndef RTL_USES_UTC
9573   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
9574       when = whenutc - offset;                   /* pseudolocal time*/
9575   }
9576 # endif
9577   /* CRTL localtime() wants local time as input, so does no tz correction */
9578   rsltmp = localtime(&when);
9579   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9580   return rsltmp;
9581 # endif
9582
9583 } /*  end of my_localtime() */
9584 /*}}}*/
9585
9586 /* Reset definitions for later calls */
9587 #define gmtime(t)    my_gmtime(t)
9588 #define localtime(t) my_localtime(t)
9589 #define time(t)      my_time(t)
9590
9591
9592 /* my_utime - update modification time of a file
9593  * calling sequence is identical to POSIX utime(), but under
9594  * VMS only the modification time is changed; ODS-2 does not
9595  * maintain access times.  Restrictions differ from the POSIX
9596  * definition in that the time can be changed as long as the
9597  * caller has permission to execute the necessary IO$_MODIFY $QIO;
9598  * no separate checks are made to insure that the caller is the
9599  * owner of the file or has special privs enabled.
9600  * Code here is based on Joe Meadows' FILE utility.
9601  */
9602
9603 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9604  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
9605  * in 100 ns intervals.
9606  */
9607 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9608
9609 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9610 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9611 {
9612   register int i;
9613   int sts;
9614   long int bintime[2], len = 2, lowbit, unixtime,
9615            secscale = 10000000; /* seconds --> 100 ns intervals */
9616   unsigned long int chan, iosb[2], retsts;
9617   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9618   struct FAB myfab = cc$rms_fab;
9619   struct NAM mynam = cc$rms_nam;
9620 #if defined (__DECC) && defined (__VAX)
9621   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9622    * at least through VMS V6.1, which causes a type-conversion warning.
9623    */
9624 #  pragma message save
9625 #  pragma message disable cvtdiftypes
9626 #endif
9627   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9628   struct fibdef myfib;
9629 #if defined (__DECC) && defined (__VAX)
9630   /* This should be right after the declaration of myatr, but due
9631    * to a bug in VAX DEC C, this takes effect a statement early.
9632    */
9633 #  pragma message restore
9634 #endif
9635   /* cast ok for read only parameter */
9636   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9637                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9638                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9639
9640   if (file == NULL || *file == '\0') {
9641     set_errno(ENOENT);
9642     set_vaxc_errno(LIB$_INVARG);
9643     return -1;
9644   }
9645   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
9646
9647   if (utimes != NULL) {
9648     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
9649      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9650      * Since time_t is unsigned long int, and lib$emul takes a signed long int
9651      * as input, we force the sign bit to be clear by shifting unixtime right
9652      * one bit, then multiplying by an extra factor of 2 in lib$emul().
9653      */
9654     lowbit = (utimes->modtime & 1) ? secscale : 0;
9655     unixtime = (long int) utimes->modtime;
9656 #   ifdef VMSISH_TIME
9657     /* If input was UTC; convert to local for sys svc */
9658     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9659 #   endif
9660     unixtime >>= 1;  secscale <<= 1;
9661     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9662     if (!(retsts & 1)) {
9663       set_errno(EVMSERR);
9664       set_vaxc_errno(retsts);
9665       return -1;
9666     }
9667     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9668     if (!(retsts & 1)) {
9669       set_errno(EVMSERR);
9670       set_vaxc_errno(retsts);
9671       return -1;
9672     }
9673   }
9674   else {
9675     /* Just get the current time in VMS format directly */
9676     retsts = sys$gettim(bintime);
9677     if (!(retsts & 1)) {
9678       set_errno(EVMSERR);
9679       set_vaxc_errno(retsts);
9680       return -1;
9681     }
9682   }
9683
9684   myfab.fab$l_fna = vmsspec;
9685   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9686   myfab.fab$l_nam = &mynam;
9687   mynam.nam$l_esa = esa;
9688   mynam.nam$b_ess = (unsigned char) sizeof esa;
9689   mynam.nam$l_rsa = rsa;
9690   mynam.nam$b_rss = (unsigned char) sizeof rsa;
9691   if (decc_efs_case_preserve)
9692       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9693
9694   /* Look for the file to be affected, letting RMS parse the file
9695    * specification for us as well.  I have set errno using only
9696    * values documented in the utime() man page for VMS POSIX.
9697    */
9698   retsts = sys$parse(&myfab,0,0);
9699   if (!(retsts & 1)) {
9700     set_vaxc_errno(retsts);
9701     if      (retsts == RMS$_PRV) set_errno(EACCES);
9702     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9703     else                         set_errno(EVMSERR);
9704     return -1;
9705   }
9706   retsts = sys$search(&myfab,0,0);
9707   if (!(retsts & 1)) {
9708     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9709     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9710     set_vaxc_errno(retsts);
9711     if      (retsts == RMS$_PRV) set_errno(EACCES);
9712     else if (retsts == RMS$_FNF) set_errno(ENOENT);
9713     else                         set_errno(EVMSERR);
9714     return -1;
9715   }
9716
9717   devdsc.dsc$w_length = mynam.nam$b_dev;
9718   /* cast ok for read only parameter */
9719   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9720
9721   retsts = sys$assign(&devdsc,&chan,0,0);
9722   if (!(retsts & 1)) {
9723     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9724     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9725     set_vaxc_errno(retsts);
9726     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
9727     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
9728     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
9729     else                               set_errno(EVMSERR);
9730     return -1;
9731   }
9732
9733   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9734   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9735
9736   memset((void *) &myfib, 0, sizeof myfib);
9737 #if defined(__DECC) || defined(__DECCXX)
9738   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9739   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9740   /* This prevents the revision time of the file being reset to the current
9741    * time as a result of our IO$_MODIFY $QIO. */
9742   myfib.fib$l_acctl = FIB$M_NORECORD;
9743 #else
9744   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9745   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9746   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9747 #endif
9748   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9749   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9750   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9751   _ckvmssts(sys$dassgn(chan));
9752   if (retsts & 1) retsts = iosb[0];
9753   if (!(retsts & 1)) {
9754     set_vaxc_errno(retsts);
9755     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9756     else                      set_errno(EVMSERR);
9757     return -1;
9758   }
9759
9760   return 0;
9761 }  /* end of my_utime() */
9762 /*}}}*/
9763
9764 /*
9765  * flex_stat, flex_lstat, flex_fstat
9766  * basic stat, but gets it right when asked to stat
9767  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9768  */
9769
9770 #ifndef _USE_STD_STAT
9771 /* encode_dev packs a VMS device name string into an integer to allow
9772  * simple comparisons. This can be used, for example, to check whether two
9773  * files are located on the same device, by comparing their encoded device
9774  * names. Even a string comparison would not do, because stat() reuses the
9775  * device name buffer for each call; so without encode_dev, it would be
9776  * necessary to save the buffer and use strcmp (this would mean a number of
9777  * changes to the standard Perl code, to say nothing of what a Perl script
9778  * would have to do.
9779  *
9780  * The device lock id, if it exists, should be unique (unless perhaps compared
9781  * with lock ids transferred from other nodes). We have a lock id if the disk is
9782  * mounted cluster-wide, which is when we tend to get long (host-qualified)
9783  * device names. Thus we use the lock id in preference, and only if that isn't
9784  * available, do we try to pack the device name into an integer (flagged by
9785  * the sign bit (LOCKID_MASK) being set).
9786  *
9787  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9788  * name and its encoded form, but it seems very unlikely that we will find
9789  * two files on different disks that share the same encoded device names,
9790  * and even more remote that they will share the same file id (if the test
9791  * is to check for the same file).
9792  *
9793  * A better method might be to use sys$device_scan on the first call, and to
9794  * search for the device, returning an index into the cached array.
9795  * The number returned would be more intelligable.
9796  * This is probably not worth it, and anyway would take quite a bit longer
9797  * on the first call.
9798  */
9799 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
9800 static mydev_t encode_dev (pTHX_ const char *dev)
9801 {
9802   int i;
9803   unsigned long int f;
9804   mydev_t enc;
9805   char c;
9806   const char *q;
9807
9808   if (!dev || !dev[0]) return 0;
9809
9810 #if LOCKID_MASK
9811   {
9812     struct dsc$descriptor_s dev_desc;
9813     unsigned long int status, lockid, item = DVI$_LOCKID;
9814
9815     /* For cluster-mounted disks, the disk lock identifier is unique, so we
9816        can try that first. */
9817     dev_desc.dsc$w_length =  strlen (dev);
9818     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
9819     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
9820     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
9821     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9822     if (lockid) return (lockid & ~LOCKID_MASK);
9823   }
9824 #endif
9825
9826   /* Otherwise we try to encode the device name */
9827   enc = 0;
9828   f = 1;
9829   i = 0;
9830   for (q = dev + strlen(dev); q--; q >= dev) {
9831     if (isdigit (*q))
9832       c= (*q) - '0';
9833     else if (isalpha (toupper (*q)))
9834       c= toupper (*q) - 'A' + (char)10;
9835     else
9836       continue; /* Skip '$'s */
9837     i++;
9838     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
9839     if (i>1) f *= 36;
9840     enc += f * (unsigned long int) c;
9841   }
9842   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
9843
9844 }  /* end of encode_dev() */
9845 #endif
9846
9847 static char namecache[NAM$C_MAXRSS+1];
9848
9849 static int
9850 is_null_device(name)
9851     const char *name;
9852 {
9853   if (decc_bug_devnull != 0) {
9854     if (strncmp("/dev/null", name, 9) == 0)
9855       return 1;
9856   }
9857     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9858        The underscore prefix, controller letter, and unit number are
9859        independently optional; for our purposes, the colon punctuation
9860        is not.  The colon can be trailed by optional directory and/or
9861        filename, but two consecutive colons indicates a nodename rather
9862        than a device.  [pr]  */
9863   if (*name == '_') ++name;
9864   if (tolower(*name++) != 'n') return 0;
9865   if (tolower(*name++) != 'l') return 0;
9866   if (tolower(*name) == 'a') ++name;
9867   if (*name == '0') ++name;
9868   return (*name++ == ':') && (*name != ':');
9869 }
9870
9871 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
9872 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9873  * subset of the applicable information.
9874  */
9875 bool
9876 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
9877 {
9878   char fname_phdev[NAM$C_MAXRSS+1];
9879 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9880   /* Namecache not workable with symbolic links, as symbolic links do
9881    *  not have extensions and directories do in VMS mode.  So in order
9882    *  to test this, the did and ino_t must be used.
9883    *
9884    * Fix-me - Hide the information in the new stat structure
9885    *          Get rid of the namecache.
9886    */
9887   if (decc_posix_compliant_pathnames == 0)
9888 #endif
9889       if (statbufp == &PL_statcache)
9890           return cando_by_name(bit,effective,namecache);
9891   {
9892     char fname[NAM$C_MAXRSS+1];
9893     unsigned long int retsts;
9894     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9895                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9896
9897     /* If the struct mystat is stale, we're OOL; stat() overwrites the
9898        device name on successive calls */
9899     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
9900     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
9901     namdsc.dsc$a_pointer = fname;
9902     namdsc.dsc$w_length = sizeof fname - 1;
9903
9904     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
9905                              &namdsc,&namdsc.dsc$w_length,0,0);
9906     if (retsts & 1) {
9907       fname[namdsc.dsc$w_length] = '\0';
9908 /*
9909  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
9910  * but if someone has redefined that logical, Perl gets very lost.  Since
9911  * we have the physical device name from the stat buffer, just paste it on.
9912  */
9913       strcpy( fname_phdev, statbufp->st_devnam );
9914       strcat( fname_phdev, strrchr(fname, ':') );
9915
9916       return cando_by_name(bit,effective,fname_phdev);
9917     }
9918     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
9919       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
9920       return FALSE;
9921     }
9922     _ckvmssts(retsts);
9923     return FALSE;  /* Should never get to here */
9924   }
9925 }  /* end of cando() */
9926 /*}}}*/
9927
9928
9929 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
9930 I32
9931 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
9932 {
9933   static char usrname[L_cuserid];
9934   static struct dsc$descriptor_s usrdsc =
9935          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
9936   char vmsname[NAM$C_MAXRSS+1];
9937   char *fileified;
9938   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
9939   unsigned short int retlen, trnlnm_iter_count;
9940   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9941   union prvdef curprv;
9942   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9943          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
9944   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9945          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9946          {0,0,0,0}};
9947   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
9948          {0,0,0,0}};
9949   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9950
9951   if (!fname || !*fname) return FALSE;
9952   /* Make sure we expand logical names, since sys$check_access doesn't */
9953   Newx(fileified, VMS_MAXRSS, char);
9954   if (!strpbrk(fname,"/]>:")) {
9955     strcpy(fileified,fname);
9956     trnlnm_iter_count = 0;
9957     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
9958         trnlnm_iter_count++;
9959         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
9960     }
9961     fname = fileified;
9962   }
9963   if (!do_rmsexpand(fname, vmsname, 1, NULL, PERL_RMSEXPAND_M_VMS)) {
9964     Safefree(fileified);
9965     return FALSE;
9966   }
9967   retlen = namdsc.dsc$w_length = strlen(vmsname);
9968   namdsc.dsc$a_pointer = vmsname;
9969   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
9970       vmsname[retlen-1] == ':') {
9971     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9972     namdsc.dsc$w_length = strlen(fileified);
9973     namdsc.dsc$a_pointer = fileified;
9974   }
9975
9976   switch (bit) {
9977     case S_IXUSR: case S_IXGRP: case S_IXOTH:
9978       access = ARM$M_EXECUTE; break;
9979     case S_IRUSR: case S_IRGRP: case S_IROTH:
9980       access = ARM$M_READ; break;
9981     case S_IWUSR: case S_IWGRP: case S_IWOTH:
9982       access = ARM$M_WRITE; break;
9983     case S_IDUSR: case S_IDGRP: case S_IDOTH:
9984       access = ARM$M_DELETE; break;
9985     default:
9986       Safefree(fileified);
9987       return FALSE;
9988   }
9989
9990   /* Before we call $check_access, create a user profile with the current
9991    * process privs since otherwise it just uses the default privs from the
9992    * UAF and might give false positives or negatives.  This only works on
9993    * VMS versions v6.0 and later since that's when sys$create_user_profile
9994    * became available.
9995    */
9996
9997   /* get current process privs and username */
9998   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9999   _ckvmssts(iosb[0]);
10000
10001 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10002
10003   /* find out the space required for the profile */
10004   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10005                                     &usrprodsc.dsc$w_length,0));
10006
10007   /* allocate space for the profile and get it filled in */
10008   Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
10009   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10010                                     &usrprodsc.dsc$w_length,0));
10011
10012   /* use the profile to check access to the file; free profile & analyze results */
10013   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10014   Safefree(usrprodsc.dsc$a_pointer);
10015   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10016
10017 #else
10018
10019   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10020
10021 #endif
10022
10023   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
10024       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10025       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10026     set_vaxc_errno(retsts);
10027     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10028     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10029     else set_errno(ENOENT);
10030     Safefree(fileified);
10031     return FALSE;
10032   }
10033   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10034     Safefree(fileified);
10035     return TRUE;
10036   }
10037   _ckvmssts(retsts);
10038
10039   Safefree(fileified);
10040   return FALSE;  /* Should never get here */
10041
10042 }  /* end of cando_by_name() */
10043 /*}}}*/
10044
10045
10046 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10047 int
10048 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10049 {
10050   if (!fstat(fd,(stat_t *) statbufp)) {
10051     if (statbufp == (Stat_t *) &PL_statcache) {
10052     char *cptr;
10053
10054         /* Save name for cando by name in VMS format */
10055         cptr = getname(fd, namecache, 1);
10056
10057         /* This should not happen, but just in case */
10058         if (cptr == NULL)
10059            namecache[0] = '\0';
10060     }
10061
10062     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10063 #ifndef _USE_STD_STAT
10064     strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
10065     statbufp->st_devnam[63] = 0;
10066     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
10067 #else
10068     /* todo:
10069      * The device is only encoded so that Perl_cando can use it to
10070      * look up ACLS.  So rmsexpand it to the 255 character version
10071      * and store it in ->st_devnam.  rmsexpand needs to be fixed
10072      * for long filenames and symbolic links first.  This also seems
10073      * to remove the need for a namecache that could be stale.
10074      */
10075 #endif
10076
10077 #   ifdef RTL_USES_UTC
10078 #   ifdef VMSISH_TIME
10079     if (VMSISH_TIME) {
10080       statbufp->st_mtime = _toloc(statbufp->st_mtime);
10081       statbufp->st_atime = _toloc(statbufp->st_atime);
10082       statbufp->st_ctime = _toloc(statbufp->st_ctime);
10083     }
10084 #   endif
10085 #   else
10086 #   ifdef VMSISH_TIME
10087     if (!VMSISH_TIME) { /* Return UTC instead of local time */
10088 #   else
10089     if (1) {
10090 #   endif
10091       statbufp->st_mtime = _toutc(statbufp->st_mtime);
10092       statbufp->st_atime = _toutc(statbufp->st_atime);
10093       statbufp->st_ctime = _toutc(statbufp->st_ctime);
10094     }
10095 #endif
10096     return 0;
10097   }
10098   return -1;
10099
10100 }  /* end of flex_fstat() */
10101 /*}}}*/
10102
10103 #if !defined(__VAX) && __CRTL_VER >= 80200000
10104 #ifdef lstat
10105 #undef lstat
10106 #endif
10107 #else
10108 #ifdef lstat
10109 #undef lstat
10110 #endif
10111 #define lstat(_x, _y) stat(_x, _y)
10112 #endif
10113
10114 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
10115
10116 static int
10117 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10118 {
10119     char fileified[NAM$C_MAXRSS+1];
10120     char temp_fspec[NAM$C_MAXRSS+300];
10121     int retval = -1;
10122     int saved_errno, saved_vaxc_errno;
10123
10124     if (!fspec) return retval;
10125     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10126     strcpy(temp_fspec, fspec);
10127     if (statbufp == (Stat_t *) &PL_statcache)
10128       do_tovmsspec(temp_fspec,namecache,0);
10129     if (decc_bug_devnull != 0) {
10130       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10131         memset(statbufp,0,sizeof *statbufp);
10132         statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
10133         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10134         statbufp->st_uid = 0x00010001;
10135         statbufp->st_gid = 0x0001;
10136         time((time_t *)&statbufp->st_mtime);
10137         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10138         return 0;
10139       }
10140     }
10141
10142     /* Try for a directory name first.  If fspec contains a filename without
10143      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10144      * and sea:[wine.dark]water. exist, we prefer the directory here.
10145      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10146      * not sea:[wine.dark]., if the latter exists.  If the intended target is
10147      * the file with null type, specify this by calling flex_stat() with
10148      * a '.' at the end of fspec.
10149      *
10150      * If we are in Posix filespec mode, accept the filename as is.
10151      */
10152 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10153   if (decc_posix_compliant_pathnames == 0) {
10154 #endif
10155     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
10156       if (lstat_flag == 0)
10157         retval = stat(fileified,(stat_t *) statbufp);
10158       else
10159         retval = lstat(fileified,(stat_t *) statbufp);
10160       if (!retval && statbufp == (Stat_t *) &PL_statcache)
10161         strcpy(namecache,fileified);
10162     }
10163     if (retval) {
10164       if (lstat_flag == 0)
10165         retval = stat(temp_fspec,(stat_t *) statbufp);
10166       else
10167         retval = lstat(temp_fspec,(stat_t *) statbufp);
10168     }
10169 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10170   } else {
10171     if (lstat_flag == 0)
10172       retval = stat(temp_fspec,(stat_t *) statbufp);
10173     else
10174       retval = lstat(temp_fspec,(stat_t *) statbufp);
10175   }
10176 #endif
10177     if (!retval) {
10178       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10179 #ifndef _USE_STD_STAT
10180       strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
10181       statbufp->st_devnam[63] = 0;
10182       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
10183 #else
10184     /* todo:
10185      * The device is only encoded so that Perl_cando can use it to
10186      * look up ACLS.  So rmsexpand it to the 255 character version
10187      * and store it in ->st_devnam.  rmsexpand needs to be fixed
10188      * for long filenames and symbolic links first.  This also seems
10189      * to remove the need for a namecache that could be stale.
10190      */
10191 #endif
10192 #     ifdef RTL_USES_UTC
10193 #     ifdef VMSISH_TIME
10194       if (VMSISH_TIME) {
10195         statbufp->st_mtime = _toloc(statbufp->st_mtime);
10196         statbufp->st_atime = _toloc(statbufp->st_atime);
10197         statbufp->st_ctime = _toloc(statbufp->st_ctime);
10198       }
10199 #     endif
10200 #     else
10201 #     ifdef VMSISH_TIME
10202       if (!VMSISH_TIME) { /* Return UTC instead of local time */
10203 #     else
10204       if (1) {
10205 #     endif
10206         statbufp->st_mtime = _toutc(statbufp->st_mtime);
10207         statbufp->st_atime = _toutc(statbufp->st_atime);
10208         statbufp->st_ctime = _toutc(statbufp->st_ctime);
10209       }
10210 #     endif
10211     }
10212     /* If we were successful, leave errno where we found it */
10213     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10214     return retval;
10215
10216 }  /* end of flex_stat_int() */
10217
10218
10219 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10220 int
10221 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10222 {
10223    return flex_stat_int(fspec, statbufp, 0);
10224 }
10225 /*}}}*/
10226
10227 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10228 int
10229 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10230 {
10231    return flex_stat_int(fspec, statbufp, 1);
10232 }
10233 /*}}}*/
10234
10235
10236 /*{{{char *my_getlogin()*/
10237 /* VMS cuserid == Unix getlogin, except calling sequence */
10238 char *
10239 my_getlogin(void)
10240 {
10241     static char user[L_cuserid];
10242     return cuserid(user);
10243 }
10244 /*}}}*/
10245
10246
10247 /*  rmscopy - copy a file using VMS RMS routines
10248  *
10249  *  Copies contents and attributes of spec_in to spec_out, except owner
10250  *  and protection information.  Name and type of spec_in are used as
10251  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
10252  *  should try to propagate timestamps from the input file to the output file.
10253  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
10254  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
10255  *  propagated to the output file at creation iff the output file specification
10256  *  did not contain an explicit name or type, and the revision date is always
10257  *  updated at the end of the copy operation.  If it is greater than 0, then
10258  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
10259  *  other than the revision date should be propagated, and bit 1 indicates
10260  *  that the revision date should be propagated.
10261  *
10262  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
10263  *
10264  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
10265  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
10266  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
10267  * as part of the Perl standard distribution under the terms of the
10268  * GNU General Public License or the Perl Artistic License.  Copies
10269  * of each may be found in the Perl standard distribution.
10270  */ /* FIXME */
10271 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
10272 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
10273 int
10274 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10275 {
10276     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
10277          rsa[NAM$C_MAXRSS], ubf[32256];
10278     unsigned long int i, sts, sts2;
10279     struct FAB fab_in, fab_out;
10280     struct RAB rab_in, rab_out;
10281     struct NAM nam;
10282     struct XABDAT xabdat;
10283     struct XABFHC xabfhc;
10284     struct XABRDT xabrdt;
10285     struct XABSUM xabsum;
10286
10287     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
10288         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10289       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10290       return 0;
10291     }
10292
10293     fab_in = cc$rms_fab;
10294     fab_in.fab$l_fna = vmsin;
10295     fab_in.fab$b_fns = strlen(vmsin);
10296     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10297     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10298     fab_in.fab$l_fop = FAB$M_SQO;
10299     fab_in.fab$l_nam =  &nam;
10300     fab_in.fab$l_xab = (void *) &xabdat;
10301
10302     nam = cc$rms_nam;
10303     nam.nam$l_rsa = rsa;
10304     nam.nam$b_rss = sizeof(rsa);
10305     nam.nam$l_esa = esa;
10306     nam.nam$b_ess = sizeof (esa);
10307     nam.nam$b_esl = nam.nam$b_rsl = 0;
10308 #ifdef NAM$M_NO_SHORT_UPCASE
10309     if (decc_efs_case_preserve)
10310         nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10311 #endif
10312
10313     xabdat = cc$rms_xabdat;        /* To get creation date */
10314     xabdat.xab$l_nxt = (void *) &xabfhc;
10315
10316     xabfhc = cc$rms_xabfhc;        /* To get record length */
10317     xabfhc.xab$l_nxt = (void *) &xabsum;
10318
10319     xabsum = cc$rms_xabsum;        /* To get key and area information */
10320
10321     if (!((sts = sys$open(&fab_in)) & 1)) {
10322       set_vaxc_errno(sts);
10323       switch (sts) {
10324         case RMS$_FNF: case RMS$_DNF:
10325           set_errno(ENOENT); break;
10326         case RMS$_DIR:
10327           set_errno(ENOTDIR); break;
10328         case RMS$_DEV:
10329           set_errno(ENODEV); break;
10330         case RMS$_SYN:
10331           set_errno(EINVAL); break;
10332         case RMS$_PRV:
10333           set_errno(EACCES); break;
10334         default:
10335           set_errno(EVMSERR);
10336       }
10337       return 0;
10338     }
10339
10340     fab_out = fab_in;
10341     fab_out.fab$w_ifi = 0;
10342     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10343     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10344     fab_out.fab$l_fop = FAB$M_SQO;
10345     fab_out.fab$l_fna = vmsout;
10346     fab_out.fab$b_fns = strlen(vmsout);
10347     fab_out.fab$l_dna = nam.nam$l_name;
10348     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
10349
10350     if (preserve_dates == 0) {  /* Act like DCL COPY */
10351       nam.nam$b_nop |= NAM$M_SYNCHK;
10352       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10353       if (!((sts = sys$parse(&fab_out)) & 1)) {
10354         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10355         set_vaxc_errno(sts);
10356         return 0;
10357       }
10358       fab_out.fab$l_xab = (void *) &xabdat;
10359       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10360     }
10361     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
10362     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10363       preserve_dates =0;      /* bitmask from this point forward   */
10364
10365     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10366     if (!((sts = sys$create(&fab_out)) & 1)) {
10367       set_vaxc_errno(sts);
10368       switch (sts) {
10369         case RMS$_DNF:
10370           set_errno(ENOENT); break;
10371         case RMS$_DIR:
10372           set_errno(ENOTDIR); break;
10373         case RMS$_DEV:
10374           set_errno(ENODEV); break;
10375         case RMS$_SYN:
10376           set_errno(EINVAL); break;
10377         case RMS$_PRV:
10378           set_errno(EACCES); break;
10379         default:
10380           set_errno(EVMSERR);
10381       }
10382       return 0;
10383     }
10384     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10385     if (preserve_dates & 2) {
10386       /* sys$close() will process xabrdt, not xabdat */
10387       xabrdt = cc$rms_xabrdt;
10388 #ifndef __GNUC__
10389       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10390 #else
10391       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10392        * is unsigned long[2], while DECC & VAXC use a struct */
10393       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10394 #endif
10395       fab_out.fab$l_xab = (void *) &xabrdt;
10396     }
10397
10398     rab_in = cc$rms_rab;
10399     rab_in.rab$l_fab = &fab_in;
10400     rab_in.rab$l_rop = RAB$M_BIO;
10401     rab_in.rab$l_ubf = ubf;
10402     rab_in.rab$w_usz = sizeof ubf;
10403     if (!((sts = sys$connect(&rab_in)) & 1)) {
10404       sys$close(&fab_in); sys$close(&fab_out);
10405       set_errno(EVMSERR); set_vaxc_errno(sts);
10406       return 0;
10407     }
10408
10409     rab_out = cc$rms_rab;
10410     rab_out.rab$l_fab = &fab_out;
10411     rab_out.rab$l_rbf = ubf;
10412     if (!((sts = sys$connect(&rab_out)) & 1)) {
10413       sys$close(&fab_in); sys$close(&fab_out);
10414       set_errno(EVMSERR); set_vaxc_errno(sts);
10415       return 0;
10416     }
10417
10418     while ((sts = sys$read(&rab_in))) {  /* always true  */
10419       if (sts == RMS$_EOF) break;
10420       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10421       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10422         sys$close(&fab_in); sys$close(&fab_out);
10423         set_errno(EVMSERR); set_vaxc_errno(sts);
10424         return 0;
10425       }
10426     }
10427
10428     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10429     sys$close(&fab_in);  sys$close(&fab_out);
10430     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10431     if (!(sts & 1)) {
10432       set_errno(EVMSERR); set_vaxc_errno(sts);
10433       return 0;
10434     }
10435
10436     return 1;
10437
10438 }  /* end of rmscopy() */
10439 #else
10440 /* ODS-5 support version */
10441 int
10442 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10443 {
10444     char *vmsin, * vmsout, *esa, *esa_out,
10445          *rsa, *ubf;
10446     unsigned long int i, sts, sts2;
10447     struct FAB fab_in, fab_out;
10448     struct RAB rab_in, rab_out;
10449     struct NAML nam;
10450     struct NAML nam_out;
10451     struct XABDAT xabdat;
10452     struct XABFHC xabfhc;
10453     struct XABRDT xabrdt;
10454     struct XABSUM xabsum;
10455
10456     Newx(vmsin, VMS_MAXRSS, char);
10457     Newx(vmsout, VMS_MAXRSS, char);
10458     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
10459         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10460       Safefree(vmsin);
10461       Safefree(vmsout);
10462       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10463       return 0;
10464     }
10465
10466     Newx(esa, VMS_MAXRSS, char);
10467     nam = cc$rms_naml;
10468     fab_in = cc$rms_fab;
10469     fab_in.fab$l_fna = (char *) -1;
10470     fab_in.fab$b_fns = 0;
10471     nam.naml$l_long_filename = vmsin;
10472     nam.naml$l_long_filename_size = strlen(vmsin);
10473     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10474     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10475     fab_in.fab$l_fop = FAB$M_SQO;
10476     fab_in.fab$l_naml =  &nam;
10477     fab_in.fab$l_xab = (void *) &xabdat;
10478
10479     Newx(rsa, VMS_MAXRSS, char);
10480     nam.naml$l_rsa = NULL;
10481     nam.naml$b_rss = 0;
10482     nam.naml$l_long_result = rsa;
10483     nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10484     nam.naml$l_esa = NULL;
10485     nam.naml$b_ess = 0;
10486     nam.naml$l_long_expand = esa;
10487     nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10488     nam.naml$b_esl = nam.naml$b_rsl = 0;
10489     nam.naml$l_long_expand_size = 0;
10490     nam.naml$l_long_result_size = 0;
10491 #ifdef NAM$M_NO_SHORT_UPCASE
10492     if (decc_efs_case_preserve)
10493         nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10494 #endif
10495
10496     xabdat = cc$rms_xabdat;        /* To get creation date */
10497     xabdat.xab$l_nxt = (void *) &xabfhc;
10498
10499     xabfhc = cc$rms_xabfhc;        /* To get record length */
10500     xabfhc.xab$l_nxt = (void *) &xabsum;
10501
10502     xabsum = cc$rms_xabsum;        /* To get key and area information */
10503
10504     if (!((sts = sys$open(&fab_in)) & 1)) {
10505       Safefree(vmsin);
10506       Safefree(vmsout);
10507       Safefree(esa);
10508       Safefree(rsa);
10509       set_vaxc_errno(sts);
10510       switch (sts) {
10511         case RMS$_FNF: case RMS$_DNF:
10512           set_errno(ENOENT); break;
10513         case RMS$_DIR:
10514           set_errno(ENOTDIR); break;
10515         case RMS$_DEV:
10516           set_errno(ENODEV); break;
10517         case RMS$_SYN:
10518           set_errno(EINVAL); break;
10519         case RMS$_PRV:
10520           set_errno(EACCES); break;
10521         default:
10522           set_errno(EVMSERR);
10523       }
10524       return 0;
10525     }
10526
10527     nam_out = nam;
10528     fab_out = fab_in;
10529     fab_out.fab$w_ifi = 0;
10530     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10531     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10532     fab_out.fab$l_fop = FAB$M_SQO;
10533     fab_out.fab$l_naml = &nam_out;
10534     fab_out.fab$l_fna = (char *) -1;
10535     fab_out.fab$b_fns = 0;
10536     nam_out.naml$l_long_filename = vmsout;
10537     nam_out.naml$l_long_filename_size = strlen(vmsout);
10538     fab_out.fab$l_dna = (char *) -1;
10539     fab_out.fab$b_dns = 0;
10540     nam_out.naml$l_long_defname = nam.naml$l_long_name;
10541     nam_out.naml$l_long_defname_size =
10542         nam.naml$l_long_name ?
10543            nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10544
10545     Newx(esa_out, VMS_MAXRSS, char);
10546     nam_out.naml$l_rsa = NULL;
10547     nam_out.naml$b_rss = 0;
10548     nam_out.naml$l_long_result = NULL;
10549     nam_out.naml$l_long_result_alloc = 0;
10550     nam_out.naml$l_esa = NULL;
10551     nam_out.naml$b_ess = 0;
10552     nam_out.naml$l_long_expand = esa_out;
10553     nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10554
10555     if (preserve_dates == 0) {  /* Act like DCL COPY */
10556       nam_out.naml$b_nop |= NAM$M_SYNCHK;
10557       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
10558       if (!((sts = sys$parse(&fab_out)) & 1)) {
10559         Safefree(vmsin);
10560         Safefree(vmsout);
10561         Safefree(esa);
10562         Safefree(rsa);
10563         Safefree(esa_out);
10564         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10565         set_vaxc_errno(sts);
10566         return 0;
10567       }
10568       fab_out.fab$l_xab = (void *) &xabdat;
10569       if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10570     }
10571     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
10572       preserve_dates =0;      /* bitmask from this point forward   */
10573
10574     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10575     if (!((sts = sys$create(&fab_out)) & 1)) {
10576       Safefree(vmsin);
10577       Safefree(vmsout);
10578       Safefree(esa);
10579       Safefree(rsa);
10580       Safefree(esa_out);
10581       set_vaxc_errno(sts);
10582       switch (sts) {
10583         case RMS$_DNF:
10584           set_errno(ENOENT); break;
10585         case RMS$_DIR:
10586           set_errno(ENOTDIR); break;
10587         case RMS$_DEV:
10588           set_errno(ENODEV); break;
10589         case RMS$_SYN:
10590           set_errno(EINVAL); break;
10591         case RMS$_PRV:
10592           set_errno(EACCES); break;
10593         default:
10594           set_errno(EVMSERR);
10595       }
10596       return 0;
10597     }
10598     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
10599     if (preserve_dates & 2) {
10600       /* sys$close() will process xabrdt, not xabdat */
10601       xabrdt = cc$rms_xabrdt;
10602 #ifndef __GNUC__
10603       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10604 #else
10605       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10606        * is unsigned long[2], while DECC & VAXC use a struct */
10607       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10608 #endif
10609       fab_out.fab$l_xab = (void *) &xabrdt;
10610     }
10611
10612     Newx(ubf, 32256, char);
10613     rab_in = cc$rms_rab;
10614     rab_in.rab$l_fab = &fab_in;
10615     rab_in.rab$l_rop = RAB$M_BIO;
10616     rab_in.rab$l_ubf = ubf;
10617     rab_in.rab$w_usz = 32256;
10618     if (!((sts = sys$connect(&rab_in)) & 1)) {
10619       sys$close(&fab_in); sys$close(&fab_out);
10620       Safefree(vmsin);
10621       Safefree(vmsout);
10622       Safefree(esa);
10623       Safefree(ubf);
10624       Safefree(rsa);
10625       Safefree(esa_out);
10626       set_errno(EVMSERR); set_vaxc_errno(sts);
10627       return 0;
10628     }
10629
10630     rab_out = cc$rms_rab;
10631     rab_out.rab$l_fab = &fab_out;
10632     rab_out.rab$l_rbf = ubf;
10633     if (!((sts = sys$connect(&rab_out)) & 1)) {
10634       sys$close(&fab_in); sys$close(&fab_out);
10635       Safefree(vmsin);
10636       Safefree(vmsout);
10637       Safefree(esa);
10638       Safefree(ubf);
10639       Safefree(rsa);
10640       Safefree(esa_out);
10641       set_errno(EVMSERR); set_vaxc_errno(sts);
10642       return 0;
10643     }
10644
10645     while ((sts = sys$read(&rab_in))) {  /* always true  */
10646       if (sts == RMS$_EOF) break;
10647       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10648       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10649         sys$close(&fab_in); sys$close(&fab_out);
10650         Safefree(vmsin);
10651         Safefree(vmsout);
10652         Safefree(esa);
10653         Safefree(ubf);
10654         Safefree(rsa);
10655         Safefree(esa_out);
10656         set_errno(EVMSERR); set_vaxc_errno(sts);
10657         return 0;
10658       }
10659     }
10660
10661
10662     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
10663     sys$close(&fab_in);  sys$close(&fab_out);
10664     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10665     if (!(sts & 1)) {
10666       Safefree(vmsin);
10667       Safefree(vmsout);
10668       Safefree(esa);
10669       Safefree(ubf);
10670       Safefree(rsa);
10671       Safefree(esa_out);
10672       set_errno(EVMSERR); set_vaxc_errno(sts);
10673       return 0;
10674     }
10675
10676     Safefree(vmsin);
10677     Safefree(vmsout);
10678     Safefree(esa);
10679     Safefree(ubf);
10680     Safefree(rsa);
10681     Safefree(esa_out);
10682     return 1;
10683
10684 }  /* end of rmscopy() */
10685 #endif
10686 /*}}}*/
10687
10688
10689 /***  The following glue provides 'hooks' to make some of the routines
10690  * from this file available from Perl.  These routines are sufficiently
10691  * basic, and are required sufficiently early in the build process,
10692  * that's it's nice to have them available to miniperl as well as the
10693  * full Perl, so they're set up here instead of in an extension.  The
10694  * Perl code which handles importation of these names into a given
10695  * package lives in [.VMS]Filespec.pm in @INC.
10696  */
10697
10698 void
10699 rmsexpand_fromperl(pTHX_ CV *cv)
10700 {
10701   dXSARGS;
10702   char *fspec, *defspec = NULL, *rslt;
10703   STRLEN n_a;
10704
10705   if (!items || items > 2)
10706     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10707   fspec = SvPV(ST(0),n_a);
10708   if (!fspec || !*fspec) XSRETURN_UNDEF;
10709   if (items == 2) defspec = SvPV(ST(1),n_a);
10710
10711   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10712   ST(0) = sv_newmortal();
10713   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10714   XSRETURN(1);
10715 }
10716
10717 void
10718 vmsify_fromperl(pTHX_ CV *cv)
10719 {
10720   dXSARGS;
10721   char *vmsified;
10722   STRLEN n_a;
10723
10724   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10725   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10726   ST(0) = sv_newmortal();
10727   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10728   XSRETURN(1);
10729 }
10730
10731 void
10732 unixify_fromperl(pTHX_ CV *cv)
10733 {
10734   dXSARGS;
10735   char *unixified;
10736   STRLEN n_a;
10737
10738   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10739   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10740   ST(0) = sv_newmortal();
10741   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10742   XSRETURN(1);
10743 }
10744
10745 void
10746 fileify_fromperl(pTHX_ CV *cv)
10747 {
10748   dXSARGS;
10749   char *fileified;
10750   STRLEN n_a;
10751
10752   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10753   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10754   ST(0) = sv_newmortal();
10755   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10756   XSRETURN(1);
10757 }
10758
10759 void
10760 pathify_fromperl(pTHX_ CV *cv)
10761 {
10762   dXSARGS;
10763   char *pathified;
10764   STRLEN n_a;
10765
10766   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10767   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10768   ST(0) = sv_newmortal();
10769   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10770   XSRETURN(1);
10771 }
10772
10773 void
10774 vmspath_fromperl(pTHX_ CV *cv)
10775 {
10776   dXSARGS;
10777   char *vmspath;
10778   STRLEN n_a;
10779
10780   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10781   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10782   ST(0) = sv_newmortal();
10783   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10784   XSRETURN(1);
10785 }
10786
10787 void
10788 unixpath_fromperl(pTHX_ CV *cv)
10789 {
10790   dXSARGS;
10791   char *unixpath;
10792   STRLEN n_a;
10793
10794   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10795   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10796   ST(0) = sv_newmortal();
10797   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10798   XSRETURN(1);
10799 }
10800
10801 void
10802 candelete_fromperl(pTHX_ CV *cv)
10803 {
10804   dXSARGS;
10805   char fspec[NAM$C_MAXRSS+1], *fsp;
10806   SV *mysv;
10807   IO *io;
10808   STRLEN n_a;
10809
10810   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10811
10812   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10813   if (SvTYPE(mysv) == SVt_PVGV) {
10814     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10815       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10816       ST(0) = &PL_sv_no;
10817       XSRETURN(1);
10818     }
10819     fsp = fspec;
10820   }
10821   else {
10822     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10823       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10824       ST(0) = &PL_sv_no;
10825       XSRETURN(1);
10826     }
10827   }
10828
10829   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10830   XSRETURN(1);
10831 }
10832
10833 void
10834 rmscopy_fromperl(pTHX_ CV *cv)
10835 {
10836   dXSARGS;
10837   char *inspec, *outspec, *inp, *outp;
10838   int date_flag;
10839   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10840                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10841   unsigned long int sts;
10842   SV *mysv;
10843   IO *io;
10844   STRLEN n_a;
10845
10846   if (items < 2 || items > 3)
10847     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10848
10849   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10850   Newx(inspec, VMS_MAXRSS, char);
10851   if (SvTYPE(mysv) == SVt_PVGV) {
10852     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10853       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10854       ST(0) = &PL_sv_no;
10855       Safefree(inspec);
10856       XSRETURN(1);
10857     }
10858     inp = inspec;
10859   }
10860   else {
10861     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10862       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10863       ST(0) = &PL_sv_no;
10864       Safefree(inspec);
10865       XSRETURN(1);
10866     }
10867   }
10868   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
10869   Newx(outspec, VMS_MAXRSS, char);
10870   if (SvTYPE(mysv) == SVt_PVGV) {
10871     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
10872       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10873       ST(0) = &PL_sv_no;
10874       Safefree(inspec);
10875       Safefree(outspec);
10876       XSRETURN(1);
10877     }
10878     outp = outspec;
10879   }
10880   else {
10881     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
10882       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10883       ST(0) = &PL_sv_no;
10884       Safefree(inspec);
10885       Safefree(outspec);
10886       XSRETURN(1);
10887     }
10888   }
10889   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
10890
10891   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
10892   Safefree(inspec);
10893   Safefree(outspec);
10894   XSRETURN(1);
10895 }
10896
10897 /* The mod2fname is limited to shorter filenames by design, so it should
10898  * not be modified to support longer EFS pathnames
10899  */
10900 void
10901 mod2fname(pTHX_ CV *cv)
10902 {
10903   dXSARGS;
10904   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10905        workbuff[NAM$C_MAXRSS*1 + 1];
10906   int total_namelen = 3, counter, num_entries;
10907   /* ODS-5 ups this, but we want to be consistent, so... */
10908   int max_name_len = 39;
10909   AV *in_array = (AV *)SvRV(ST(0));
10910
10911   num_entries = av_len(in_array);
10912
10913   /* All the names start with PL_. */
10914   strcpy(ultimate_name, "PL_");
10915
10916   /* Clean up our working buffer */
10917   Zero(work_name, sizeof(work_name), char);
10918
10919   /* Run through the entries and build up a working name */
10920   for(counter = 0; counter <= num_entries; counter++) {
10921     /* If it's not the first name then tack on a __ */
10922     if (counter) {
10923       strcat(work_name, "__");
10924     }
10925     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10926                            PL_na));
10927   }
10928
10929   /* Check to see if we actually have to bother...*/
10930   if (strlen(work_name) + 3 <= max_name_len) {
10931     strcat(ultimate_name, work_name);
10932   } else {
10933     /* It's too darned big, so we need to go strip. We use the same */
10934     /* algorithm as xsubpp does. First, strip out doubled __ */
10935     char *source, *dest, last;
10936     dest = workbuff;
10937     last = 0;
10938     for (source = work_name; *source; source++) {
10939       if (last == *source && last == '_') {
10940         continue;
10941       }
10942       *dest++ = *source;
10943       last = *source;
10944     }
10945     /* Go put it back */
10946     strcpy(work_name, workbuff);
10947     /* Is it still too big? */
10948     if (strlen(work_name) + 3 > max_name_len) {
10949       /* Strip duplicate letters */
10950       last = 0;
10951       dest = workbuff;
10952       for (source = work_name; *source; source++) {
10953         if (last == toupper(*source)) {
10954         continue;
10955         }
10956         *dest++ = *source;
10957         last = toupper(*source);
10958       }
10959       strcpy(work_name, workbuff);
10960     }
10961
10962     /* Is it *still* too big? */
10963     if (strlen(work_name) + 3 > max_name_len) {
10964       /* Too bad, we truncate */
10965       work_name[max_name_len - 2] = 0;
10966     }
10967     strcat(ultimate_name, work_name);
10968   }
10969
10970   /* Okay, return it */
10971   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10972   XSRETURN(1);
10973 }
10974
10975 void
10976 hushexit_fromperl(pTHX_ CV *cv)
10977 {
10978     dXSARGS;
10979
10980     if (items > 0) {
10981         VMSISH_HUSHED = SvTRUE(ST(0));
10982     }
10983     ST(0) = boolSV(VMSISH_HUSHED);
10984     XSRETURN(1);
10985 }
10986
10987 #ifdef HAS_SYMLINK
10988 static char *
10989 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10990
10991 void
10992 vms_realpath_fromperl(pTHX_ CV *cv)
10993 {
10994   dXSARGS;
10995   char *fspec, *rslt_spec, *rslt;
10996   STRLEN n_a;
10997
10998   if (!items || items != 1)
10999     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11000
11001   fspec = SvPV(ST(0),n_a);
11002   if (!fspec || !*fspec) XSRETURN_UNDEF;
11003
11004   Newx(rslt_spec, VMS_MAXRSS + 1, char);
11005   rslt = do_vms_realpath(fspec, rslt_spec);
11006   ST(0) = sv_newmortal();
11007   if (rslt != NULL)
11008     sv_usepvn(ST(0),rslt,strlen(rslt));
11009   else
11010     Safefree(rslt_spec);
11011   XSRETURN(1);
11012 }
11013 #endif
11014
11015 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11016 int do_vms_case_tolerant(void);
11017
11018 void
11019 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11020 {
11021   dXSARGS;
11022   ST(0) = boolSV(do_vms_case_tolerant());
11023   XSRETURN(1);
11024 }
11025 #endif
11026
11027 void
11028 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11029                           struct interp_intern *dst)
11030 {
11031     memcpy(dst,src,sizeof(struct interp_intern));
11032 }
11033
11034 void
11035 Perl_sys_intern_clear(pTHX)
11036 {
11037 }
11038
11039 void
11040 Perl_sys_intern_init(pTHX)
11041 {
11042     unsigned int ix = RAND_MAX;
11043     double x;
11044
11045     VMSISH_HUSHED = 0;
11046
11047     /* fix me later to track running under GNV */
11048     /* this allows some limited testing */
11049     MY_POSIX_EXIT = decc_filename_unix_report;
11050
11051     x = (float)ix;
11052     MY_INV_RAND_MAX = 1./x;
11053 }
11054
11055 void
11056 init_os_extras(void)
11057 {
11058   dTHX;
11059   char* file = __FILE__;
11060   char temp_buff[512];
11061   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
11062     no_translate_barewords = TRUE;
11063   } else {
11064     no_translate_barewords = FALSE;
11065   }
11066
11067   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11068   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11069   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11070   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11071   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11072   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11073   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11074   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11075   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11076   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11077   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11078 #ifdef HAS_SYMLINK
11079   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11080 #endif
11081 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11082   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11083 #endif
11084
11085   store_pipelocs(aTHX);         /* will redo any earlier attempts */
11086
11087   return;
11088 }
11089
11090 #ifdef HAS_SYMLINK
11091
11092 #if __CRTL_VER == 80200000
11093 /* This missed getting in to the DECC SDK for 8.2 */
11094 char *realpath(const char *file_name, char * resolved_name, ...);
11095 #endif
11096
11097 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11098 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11099  * The perl fallback routine to provide realpath() is not as efficient
11100  * on OpenVMS.
11101  */
11102 static char *
11103 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11104 {
11105     return realpath(filespec, outbuf);
11106 }
11107
11108 /*}}}*/
11109 /* External entry points */
11110 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11111 { return do_vms_realpath(filespec, outbuf); }
11112 #else
11113 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11114 { return NULL; }
11115 #endif
11116
11117
11118 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11119 /* case_tolerant */
11120
11121 /*{{{int do_vms_case_tolerant(void)*/
11122 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11123  * controlled by a process setting.
11124  */
11125 int do_vms_case_tolerant(void)
11126 {
11127     return vms_process_case_tolerant;
11128 }
11129 /*}}}*/
11130 /* External entry points */
11131 int Perl_vms_case_tolerant(void)
11132 { return do_vms_case_tolerant(); }
11133 #else
11134 int Perl_vms_case_tolerant(void)
11135 { return vms_process_case_tolerant; }
11136 #endif
11137
11138
11139  /* Start of DECC RTL Feature handling */
11140
11141 static int sys_trnlnm
11142    (const char * logname,
11143     char * value,
11144     int value_len)
11145 {
11146     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11147     const unsigned long attr = LNM$M_CASE_BLIND;
11148     struct dsc$descriptor_s name_dsc;
11149     int status;
11150     unsigned short result;
11151     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11152                                 {0, 0, 0, 0}};
11153
11154     name_dsc.dsc$w_length = strlen(logname);
11155     name_dsc.dsc$a_pointer = (char *)logname;
11156     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11157     name_dsc.dsc$b_class = DSC$K_CLASS_S;
11158
11159     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11160
11161     if ($VMS_STATUS_SUCCESS(status)) {
11162
11163          /* Null terminate and return the string */
11164         /*--------------------------------------*/
11165         value[result] = 0;
11166     }
11167
11168     return status;
11169 }
11170
11171 static int sys_crelnm
11172    (const char * logname,
11173     const char * value)
11174 {
11175     int ret_val;
11176     const char * proc_table = "LNM$PROCESS_TABLE";
11177     struct dsc$descriptor_s proc_table_dsc;
11178     struct dsc$descriptor_s logname_dsc;
11179     struct itmlst_3 item_list[2];
11180
11181     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11182     proc_table_dsc.dsc$w_length = strlen(proc_table);
11183     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11184     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11185
11186     logname_dsc.dsc$a_pointer = (char *) logname;
11187     logname_dsc.dsc$w_length = strlen(logname);
11188     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11189     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11190
11191     item_list[0].buflen = strlen(value);
11192     item_list[0].itmcode = LNM$_STRING;
11193     item_list[0].bufadr = (char *)value;
11194     item_list[0].retlen = NULL;
11195
11196     item_list[1].buflen = 0;
11197     item_list[1].itmcode = 0;
11198
11199     ret_val = sys$crelnm
11200                        (NULL,
11201                         (const struct dsc$descriptor_s *)&proc_table_dsc,
11202                         (const struct dsc$descriptor_s *)&logname_dsc,
11203                         NULL,
11204                         (const struct item_list_3 *) item_list);
11205
11206     return ret_val;
11207 }
11208
11209
11210 /* C RTL Feature settings */
11211
11212 static int set_features
11213    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
11214     int (* cli_routine)(void),  /* Not documented */
11215     void *image_info)           /* Not documented */
11216 {
11217     int status;
11218     int s;
11219     int dflt;
11220     char* str;
11221     char val_str[10];
11222 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11223     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
11224     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
11225     unsigned long case_perm;
11226     unsigned long case_image;
11227 #endif
11228
11229     /* Allow an exception to bring Perl into the VMS debugger */
11230     vms_debug_on_exception = 0;
11231     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
11232     if ($VMS_STATUS_SUCCESS(status)) {
11233        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11234          vms_debug_on_exception = 1;
11235        else
11236          vms_debug_on_exception = 0;
11237     }
11238
11239
11240     /* hacks to see if known bugs are still present for testing */
11241
11242     /* Readdir is returning filenames in VMS syntax always */
11243     decc_bug_readdir_efs1 = 1;
11244     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
11245     if ($VMS_STATUS_SUCCESS(status)) {
11246        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11247          decc_bug_readdir_efs1 = 1;
11248        else
11249          decc_bug_readdir_efs1 = 0;
11250     }
11251
11252     /* PCP mode requires creating /dev/null special device file */
11253     decc_bug_devnull = 1;
11254     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
11255     if ($VMS_STATUS_SUCCESS(status)) {
11256        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11257           decc_bug_devnull = 1;
11258        else
11259           decc_bug_devnull = 0;
11260     }
11261
11262     /* fgetname returning a VMS name in UNIX mode */
11263     decc_bug_fgetname = 1;
11264     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
11265     if ($VMS_STATUS_SUCCESS(status)) {
11266       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11267         decc_bug_fgetname = 1;
11268       else
11269         decc_bug_fgetname = 0;
11270     }
11271
11272     /* UNIX directory names with no paths are broken in a lot of places */
11273     decc_dir_barename = 1;
11274     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
11275     if ($VMS_STATUS_SUCCESS(status)) {
11276       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11277         decc_dir_barename = 1;
11278       else
11279         decc_dir_barename = 0;
11280     }
11281
11282 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11283     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
11284     if (s >= 0) {
11285         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
11286         if (decc_disable_to_vms_logname_translation < 0)
11287             decc_disable_to_vms_logname_translation = 0;
11288     }
11289
11290     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
11291     if (s >= 0) {
11292         decc_efs_case_preserve = decc$feature_get_value(s, 1);
11293         if (decc_efs_case_preserve < 0)
11294             decc_efs_case_preserve = 0;
11295     }
11296
11297     s = decc$feature_get_index("DECC$EFS_CHARSET");
11298     if (s >= 0) {
11299         decc_efs_charset = decc$feature_get_value(s, 1);
11300         if (decc_efs_charset < 0)
11301             decc_efs_charset = 0;
11302     }
11303
11304     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
11305     if (s >= 0) {
11306         decc_filename_unix_report = decc$feature_get_value(s, 1);
11307         if (decc_filename_unix_report > 0)
11308             decc_filename_unix_report = 1;
11309         else
11310             decc_filename_unix_report = 0;
11311     }
11312
11313     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
11314     if (s >= 0) {
11315         decc_filename_unix_only = decc$feature_get_value(s, 1);
11316         if (decc_filename_unix_only > 0) {
11317             decc_filename_unix_only = 1;
11318         }
11319         else {
11320             decc_filename_unix_only = 0;
11321         }
11322     }
11323
11324     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
11325     if (s >= 0) {
11326         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
11327         if (decc_filename_unix_no_version < 0)
11328             decc_filename_unix_no_version = 0;
11329     }
11330
11331     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
11332     if (s >= 0) {
11333         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
11334         if (decc_readdir_dropdotnotype < 0)
11335             decc_readdir_dropdotnotype = 0;
11336     }
11337
11338     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
11339     if ($VMS_STATUS_SUCCESS(status)) {
11340         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
11341         if (s >= 0) {
11342             dflt = decc$feature_get_value(s, 4);
11343             if (dflt > 0) {
11344                 decc_disable_posix_root = decc$feature_get_value(s, 1);
11345                 if (decc_disable_posix_root <= 0) {
11346                     decc$feature_set_value(s, 1, 1);
11347                     decc_disable_posix_root = 1;
11348                 }
11349             }
11350             else {
11351                 /* Traditionally Perl assumes this is off */
11352                 decc_disable_posix_root = 1;
11353                 decc$feature_set_value(s, 1, 1);
11354             }
11355         }
11356     }
11357
11358 #if __CRTL_VER >= 80200000
11359     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
11360     if (s >= 0) {
11361         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11362         if (decc_posix_compliant_pathnames < 0)
11363             decc_posix_compliant_pathnames = 0;
11364         if (decc_posix_compliant_pathnames > 4)
11365             decc_posix_compliant_pathnames = 0;
11366     }
11367
11368 #endif
11369 #else
11370     status = sys_trnlnm
11371         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11372     if ($VMS_STATUS_SUCCESS(status)) {
11373         val_str[0] = _toupper(val_str[0]);
11374         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11375            decc_disable_to_vms_logname_translation = 1;
11376         }
11377     }
11378
11379 #ifndef __VAX
11380     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11381     if ($VMS_STATUS_SUCCESS(status)) {
11382         val_str[0] = _toupper(val_str[0]);
11383         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11384            decc_efs_case_preserve = 1;
11385         }
11386     }
11387 #endif
11388
11389     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11390     if ($VMS_STATUS_SUCCESS(status)) {
11391         val_str[0] = _toupper(val_str[0]);
11392         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11393            decc_filename_unix_report = 1;
11394         }
11395     }
11396     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11397     if ($VMS_STATUS_SUCCESS(status)) {
11398         val_str[0] = _toupper(val_str[0]);
11399         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11400            decc_filename_unix_only = 1;
11401            decc_filename_unix_report = 1;
11402         }
11403     }
11404     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11405     if ($VMS_STATUS_SUCCESS(status)) {
11406         val_str[0] = _toupper(val_str[0]);
11407         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11408            decc_filename_unix_no_version = 1;
11409         }
11410     }
11411     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11412     if ($VMS_STATUS_SUCCESS(status)) {
11413         val_str[0] = _toupper(val_str[0]);
11414         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11415            decc_readdir_dropdotnotype = 1;
11416         }
11417     }
11418 #endif
11419
11420 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11421
11422      /* Report true case tolerance */
11423     /*----------------------------*/
11424     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11425     if (!$VMS_STATUS_SUCCESS(status))
11426         case_perm = PPROP$K_CASE_BLIND;
11427     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11428     if (!$VMS_STATUS_SUCCESS(status))
11429         case_image = PPROP$K_CASE_BLIND;
11430     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11431         (case_image == PPROP$K_CASE_SENSITIVE))
11432         vms_process_case_tolerant = 0;
11433
11434 #endif
11435
11436
11437     /* CRTL can be initialized past this point, but not before. */
11438 /*    DECC$CRTL_INIT(); */
11439
11440     return SS$_NORMAL;
11441 }
11442
11443 #ifdef __DECC
11444 /* DECC dependent attributes */
11445 #if __DECC_VER < 60560002
11446 #define relative
11447 #define not_executable
11448 #else
11449 #define relative ,rel
11450 #define not_executable ,noexe
11451 #endif
11452 #pragma nostandard
11453 #pragma extern_model save
11454 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11455 #endif
11456         const __align (LONGWORD) int spare[8] = {0};
11457 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11458 /*                        NOWRT, LONG */
11459 #ifdef __DECC
11460 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11461         nowrt,noshr relative not_executable
11462 #endif
11463 const long vms_cc_features = (const long)set_features;
11464
11465 /*
11466 ** Force a reference to LIB$INITIALIZE to ensure it
11467 ** exists in the image.
11468 */
11469 int lib$initialize(void);
11470 #ifdef __DECC
11471 #pragma extern_model strict_refdef
11472 #endif
11473     int lib_init_ref = (int) lib$initialize;
11474
11475 #ifdef __DECC
11476 #pragma extern_model restore
11477 #pragma standard
11478 #endif
11479
11480 /*  End of vms.c */