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 #ifdef __DECC
 171 #pragma message restore
 172 #pragma member_alignment restore
 173 #endif
 174
 175 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
 176 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
 177 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
 178 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
 179 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
 180 #define do_vms_realpath(a,b)            mp_do_vms_realpath(aTHX_ a,b)
 181 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
 182 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
 183 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 184 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 185 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 186
 187 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
 188 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
 189 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
 190 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
 191
 192 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 193 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 194
 195 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 196  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 197  * the Perl facility.
 198  */
 199 #define PERL_LNM_MAX_ITER 10
 200
 201   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 202 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 203 #define MAX_DCL_SYMBOL          (8192)
 204 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 205 #else
 206 #define MAX_DCL_SYMBOL          (1024)
 207 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 208 #endif
 209
 210 static char *__mystrtolower(char *str)
 211 {
 212   if (str) for (; *str; ++str) *str= tolower(*str);
 213   return str;
 214 }
 215
 216 static struct dsc$descriptor_s fildevdsc =
 217   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 218 static struct dsc$descriptor_s crtlenvdsc =
 219   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 220 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 221 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 222 static struct dsc$descriptor_s **env_tables = defenv;
 223 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 224
 225 /* True if we shouldn't treat barewords as logicals during directory */
 226 /* munching */
 227 static int no_translate_barewords;
 228
 229 #ifndef RTL_USES_UTC
 230 static int tz_updated = 1;
 231 #endif
 232
 233 /* DECC Features that may need to affect how Perl interprets
 234  * displays filename information
 235  */
 236 static int decc_disable_to_vms_logname_translation = 1;
 237 static int decc_disable_posix_root = 1;
 238 int decc_efs_case_preserve = 0;
 239 static int decc_efs_charset = 0;
 240 static int decc_filename_unix_no_version = 0;
 241 static int decc_filename_unix_only = 0;
 242 int decc_filename_unix_report = 0;
 243 int decc_posix_compliant_pathnames = 0;
 244 int decc_readdir_dropdotnotype = 0;
 245 static int vms_process_case_tolerant = 1;
 246
 247 /* bug workarounds if needed */
 248 int decc_bug_readdir_efs1 = 0;
 249 int decc_bug_devnull = 0;
 250 int decc_bug_fgetname = 0;
 251 int decc_dir_barename = 0;
 252
 253 /* Is this a UNIX file specification?
 254  *   No longer a simple check with EFS file specs
 255  *   For now, not a full check, but need to
 256  *   handle POSIX ^UP^ specifications
 257  *   Fixing to handle ^/ cases would require
 258  *   changes to many other conversion routines.
 259  */
 260
 261 static is_unix_filespec(const char *path)
 262 {
 263 int ret_val;
 264 const char * pch1;
 265
 266     ret_val = 0;
 267     if (strncmp(path,"\"^UP^",5) != 0) {
 268         pch1 = strchr(path, '/');
 269         if (pch1 != NULL)
 270             ret_val = 1;
 271         else {
 272
 273             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 274             if (decc_filename_unix_report || decc_filename_unix_only) {
 275             if (strcmp(path,".") == 0)
 276                 ret_val = 1;
 277             }
 278         }
 279     }
 280     return ret_val;
 281 }
 282
 283
 284 /* my_maxidx
 285  * Routine to retrieve the maximum equivalence index for an input
 286  * logical name.  Some calls to this routine have no knowledge if
 287  * the variable is a logical or not.  So on error we return a max
 288  * index of zero.
 289  */
 290 /*{{{int my_maxidx(const char *lnm) */
 291 static int
 292 my_maxidx(const char *lnm)
 293 {
 294     int status;
 295     int midx;
 296     int attr = LNM$M_CASE_BLIND;
 297     struct dsc$descriptor lnmdsc;
 298     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 299                                 {0, 0, 0, 0}};
 300
 301     lnmdsc.dsc$w_length = strlen(lnm);
 302     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 303     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 304     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 305
 306     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 307     if ((status & 1) == 0)
 308        midx = 0;
 309
 310     return (midx);
 311 }
 312 /*}}}*/
 313
 314 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 315 int
 316 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 317   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 318 {
 319     const char *cp1;
 320     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 321     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 322     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 323     int midx;
 324     unsigned char acmode;
 325     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 326                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 327     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 328                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 329                                  {0, 0, 0, 0}};
 330     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 331 #if defined(PERL_IMPLICIT_CONTEXT)
 332     pTHX = NULL;
 333     if (PL_curinterp) {
 334       aTHX = PERL_GET_INTERP;
 335     } else {
 336       aTHX = NULL;
 337     }
 338 #endif
 339
 340     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 341       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 342     }
 343     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 344       *cp2 = _toupper(*cp1);
 345       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 346         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 347         return 0;
 348       }
 349     }
 350     lnmdsc.dsc$w_length = cp1 - lnm;
 351     lnmdsc.dsc$a_pointer = uplnm;
 352     uplnm[lnmdsc.dsc$w_length] = '\0';
 353     secure = flags & PERL__TRNENV_SECURE;
 354     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 355     if (!tabvec || !*tabvec) tabvec = env_tables;
 356
 357     for (curtab = 0; tabvec[curtab]; curtab++) {
 358       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 359         if (!ivenv && !secure) {
 360           char *eq, *end;
 361           int i;
 362           if (!environ) {
 363             ivenv = 1;
 364             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 365             continue;
 366           }
 367           retsts = SS$_NOLOGNAM;
 368           for (i = 0; environ[i]; i++) {
 369             if ((eq = strchr(environ[i],'=')) &&
 370                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 371                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 372               eq++;
 373               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 374               if (!eqvlen) continue;
 375               retsts = SS$_NORMAL;
 376               break;
 377             }
 378           }
 379           if (retsts != SS$_NOLOGNAM) break;
 380         }
 381       }
 382       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 383                !str$case_blind_compare(&tmpdsc,&clisym)) {
 384         if (!ivsym && !secure) {
 385           unsigned short int deflen = LNM$C_NAMLENGTH;
 386           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 387           /* dynamic dsc to accomodate possible long value */
 388           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 389           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 390           if (retsts & 1) {
 391             if (eqvlen > MAX_DCL_SYMBOL) {
 392               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 393               eqvlen = MAX_DCL_SYMBOL;
 394               /* Special hack--we might be called before the interpreter's */
 395               /* fully initialized, in which case either thr or PL_curcop */
 396               /* might be bogus. We have to check, since ckWARN needs them */
 397               /* both to be valid if running threaded */
 398                 if (ckWARN(WARN_MISC)) {
 399                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 400                 }
 401             }
 402             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 403           }
 404           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 405           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 406           if (retsts == LIB$_NOSUCHSYM) continue;
 407           break;
 408         }
 409       }
 410       else if (!ivlnm) {
 411         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 412           midx = my_maxidx(lnm);
 413           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 414             lnmlst[1].bufadr = cp2;
 415             eqvlen = 0;
 416             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 417             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 418             if (retsts == SS$_NOLOGNAM) break;
 419             /* PPFs have a prefix */
 420             if (
 421 #if INTSIZE == 4
 422                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 423 #endif
 424                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 425                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 426                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 427                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 428                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 429               memmove(eqv,eqv+4,eqvlen-4);
 430               eqvlen -= 4;
 431             }
 432             cp2 += eqvlen;
 433             *cp2 = '\0';
 434           }
 435           if ((retsts == SS$_IVLOGNAM) ||
 436               (retsts == SS$_NOLOGNAM)) { continue; }
 437         }
 438         else {
 439           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 440           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 441           if (retsts == SS$_NOLOGNAM) continue;
 442           eqv[eqvlen] = '\0';
 443         }
 444         eqvlen = strlen(eqv);
 445         break;
 446       }
 447     }
 448     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 449     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 450              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 451              retsts == SS$_NOLOGNAM) {
 452       set_errno(EINVAL);  set_vaxc_errno(retsts);
 453     }
 454     else _ckvmssts(retsts);
 455     return 0;
 456 }  /* end of vmstrnenv */
 457 /*}}}*/
 458
 459 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 460 /* Define as a function so we can access statics. */
 461 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 462 {
 463   return vmstrnenv(lnm,eqv,idx,fildev,
 464 #ifdef SECURE_INTERNAL_GETENV
 465                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 466 #else
 467                    0
 468 #endif
 469                                                                               );
 470 }
 471 /*}}}*/
 472
 473 /* my_getenv
 474  * Note: Uses Perl temp to store result so char * can be returned to
 475  * caller; this pointer will be invalidated at next Perl statement
 476  * transition.
 477  * We define this as a function rather than a macro in terms of my_getenv_len()
 478  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 479  * allocate SVs).
 480  */
 481 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 482 char *
 483 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 484 {
 485     const char *cp1;
 486     static char *__my_getenv_eqv = NULL;
 487     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 488     unsigned long int idx = 0;
 489     int trnsuccess, success, secure, saverr, savvmserr;
 490     int midx, flags;
 491     SV *tmpsv;
 492
 493     midx = my_maxidx(lnm) + 1;
 494
 495     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 496       /* Set up a temporary buffer for the return value; Perl will
 497        * clean it up at the next statement transition */
 498       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 499       if (!tmpsv) return NULL;
 500       eqv = SvPVX(tmpsv);
 501     }
 502     else {
 503       /* Assume no interpreter ==> single thread */
 504       if (__my_getenv_eqv != NULL) {
 505         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 506       }
 507       else {
 508         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 509       }
 510       eqv = __my_getenv_eqv;
 511     }
 512
 513     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 514     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 515       int len;
 516       getcwd(eqv,LNM$C_NAMLENGTH);
 517
 518       len = strlen(eqv);
 519
 520       /* Get rid of "000000/ in rooted filespecs */
 521       if (len > 7) {
 522         char * zeros;
 523         zeros = strstr(eqv, "/000000/");
 524         if (zeros != NULL) {
 525           int mlen;
 526           mlen = len - (zeros - eqv) - 7;
 527           memmove(zeros, &zeros[7], mlen);
 528           len = len - 7;
 529           eqv[len] = '\0';
 530         }
 531       }
 532       return eqv;
 533     }
 534     else {
 535       /* Impose security constraints only if tainting */
 536       if (sys) {
 537         /* Impose security constraints only if tainting */
 538         secure = PL_curinterp ? PL_tainting : will_taint;
 539         saverr = errno;  savvmserr = vaxc$errno;
 540       }
 541       else {
 542         secure = 0;
 543       }
 544
 545       flags =
 546 #ifdef SECURE_INTERNAL_GETENV
 547               secure ? PERL__TRNENV_SECURE : 0
 548 #else
 549               0
 550 #endif
 551       ;
 552
 553       /* For the getenv interface we combine all the equivalence names
 554        * of a search list logical into one value to acquire a maximum
 555        * value length of 255*128 (assuming %ENV is using logicals).
 556        */
 557       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 558
 559       /* If the name contains a semicolon-delimited index, parse it
 560        * off and make sure we only retrieve the equivalence name for
 561        * that index.  */
 562       if ((cp2 = strchr(lnm,';')) != NULL) {
 563         strcpy(uplnm,lnm);
 564         uplnm[cp2-lnm] = '\0';
 565         idx = strtoul(cp2+1,NULL,0);
 566         lnm = uplnm;
 567         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 568       }
 569
 570       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
 571
 572       /* Discard NOLOGNAM on internal calls since we're often looking
 573        * for an optional name, and this "error" often shows up as the
 574        * (bogus) exit status for a die() call later on.  */
 575       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 576       return success ? eqv : Nullch;
 577     }
 578
 579 }  /* end of my_getenv() */
 580 /*}}}*/
 581
 582
 583 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 584 char *
 585 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 586 {
 587     const char *cp1;
 588     char *buf, *cp2;
 589     unsigned long idx = 0;
 590     int midx, flags;
 591     static char *__my_getenv_len_eqv = NULL;
 592     int secure, saverr, savvmserr;
 593     SV *tmpsv;
 594
 595     midx = my_maxidx(lnm) + 1;
 596
 597     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 598       /* Set up a temporary buffer for the return value; Perl will
 599        * clean it up at the next statement transition */
 600       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 601       if (!tmpsv) return NULL;
 602       buf = SvPVX(tmpsv);
 603     }
 604     else {
 605       /* Assume no interpreter ==> single thread */
 606       if (__my_getenv_len_eqv != NULL) {
 607         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 608       }
 609       else {
 610         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 611       }
 612       buf = __my_getenv_len_eqv;
 613     }
 614
 615     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 616     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 617     char * zeros;
 618
 619       getcwd(buf,LNM$C_NAMLENGTH);
 620       *len = strlen(buf);
 621
 622       /* Get rid of "000000/ in rooted filespecs */
 623       if (*len > 7) {
 624       zeros = strstr(buf, "/000000/");
 625       if (zeros != NULL) {
 626         int mlen;
 627         mlen = *len - (zeros - buf) - 7;
 628         memmove(zeros, &zeros[7], mlen);
 629         *len = *len - 7;
 630         buf[*len] = '\0';
 631         }
 632       }
 633       return buf;
 634     }
 635     else {
 636       if (sys) {
 637         /* Impose security constraints only if tainting */
 638         secure = PL_curinterp ? PL_tainting : will_taint;
 639         saverr = errno;  savvmserr = vaxc$errno;
 640       }
 641       else {
 642         secure = 0;
 643       }
 644
 645       flags =
 646 #ifdef SECURE_INTERNAL_GETENV
 647               secure ? PERL__TRNENV_SECURE : 0
 648 #else
 649               0
 650 #endif
 651       ;
 652
 653       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 654
 655       if ((cp2 = strchr(lnm,';')) != NULL) {
 656         strcpy(buf,lnm);
 657         buf[cp2-lnm] = '\0';
 658         idx = strtoul(cp2+1,NULL,0);
 659         lnm = buf;
 660         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 661       }
 662
 663       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
 664
 665       /* Get rid of "000000/ in rooted filespecs */
 666       if (*len > 7) {
 667       char * zeros;
 668         zeros = strstr(buf, "/000000/");
 669         if (zeros != NULL) {
 670           int mlen;
 671           mlen = *len - (zeros - buf) - 7;
 672           memmove(zeros, &zeros[7], mlen);
 673           *len = *len - 7;
 674           buf[*len] = '\0';
 675         }
 676       }
 677
 678       /* Discard NOLOGNAM on internal calls since we're often looking
 679        * for an optional name, and this "error" often shows up as the
 680        * (bogus) exit status for a die() call later on.  */
 681       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 682       return *len ? buf : Nullch;
 683     }
 684
 685 }  /* end of my_getenv_len() */
 686 /*}}}*/
 687
 688 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 689
 690 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 691
 692 /*{{{ void prime_env_iter() */
 693 void
 694 prime_env_iter(void)
 695 /* Fill the %ENV associative array with all logical names we can
 696  * find, in preparation for iterating over it.
 697  */
 698 {
 699   static int primed = 0;
 700   HV *seenhv = NULL, *envhv;
 701   SV *sv = NULL;
 702   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 703   unsigned short int chan;
 704 #ifndef CLI$M_TRUSTED
 705 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 706 #endif
 707   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 708   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 709   long int i;
 710   bool have_sym = FALSE, have_lnm = FALSE;
 711   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 712   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 713   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 714   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 715   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 716 #if defined(PERL_IMPLICIT_CONTEXT)
 717   pTHX;
 718 #endif
 719 #if defined(USE_ITHREADS)
 720   static perl_mutex primenv_mutex;
 721   MUTEX_INIT(&primenv_mutex);
 722 #endif
 723
 724 #if defined(PERL_IMPLICIT_CONTEXT)
 725     /* We jump through these hoops because we can be called at */
 726     /* platform-specific initialization time, which is before anything is */
 727     /* set up--we can't even do a plain dTHX since that relies on the */
 728     /* interpreter structure to be initialized */
 729     if (PL_curinterp) {
 730       aTHX = PERL_GET_INTERP;
 731     } else {
 732       aTHX = NULL;
 733     }
 734 #endif
 735
 736   if (primed || !PL_envgv) return;
 737   MUTEX_LOCK(&primenv_mutex);
 738   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
 739   envhv = GvHVn(PL_envgv);
 740   /* Perform a dummy fetch as an lval to insure that the hash table is
 741    * set up.  Otherwise, the hv_store() will turn into a nullop. */
 742   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
 743
 744   for (i = 0; env_tables[i]; i++) {
 745      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 746          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
 747      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
 748   }
 749   if (have_sym || have_lnm) {
 750     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 751     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 752     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
 753     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
 754   }
 755
 756   for (i--; i >= 0; i--) {
 757     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
 758       char *start;
 759       int j;
 760       for (j = 0; environ[j]; j++) {
 761         if (!(start = strchr(environ[j],'='))) {
 762           if (ckWARN(WARN_INTERNAL))
 763             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
 764         }
 765         else {
 766           start++;
 767           sv = newSVpv(start,0);
 768           SvTAINTED_on(sv);
 769           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
 770         }
 771       }
 772       continue;
 773     }
 774     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 775              !str$case_blind_compare(&tmpdsc,&clisym)) {
 776       strcpy(cmd,"Show Symbol/Global *");
 777       cmddsc.dsc$w_length = 20;
 778       if (env_tables[i]->dsc$w_length == 12 &&
 779           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
 780           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
 781       flags = defflags | CLI$M_NOLOGNAM;
 782     }
 783     else {
 784       strcpy(cmd,"Show Logical *");
 785       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
 786         strcat(cmd," /Table=");
 787         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
 788         cmddsc.dsc$w_length = strlen(cmd);
 789       }
 790       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
 791       flags = defflags | CLI$M_NOCLISYM;
 792     }
 793
 794     /* Create a new subprocess to execute each command, to exclude the
 795      * remote possibility that someone could subvert a mbx or file used
 796      * to write multiple commands to a single subprocess.
 797      */
 798     do {
 799       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
 800                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
 801       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
 802       defflags &= ~CLI$M_TRUSTED;
 803     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
 804     _ckvmssts(retsts);
 805     if (!buf) Newx(buf,mbxbufsiz + 1,char);
 806     if (seenhv) SvREFCNT_dec(seenhv);
 807     seenhv = newHV();
 808     while (1) {
 809       char *cp1, *cp2, *key;
 810       unsigned long int sts, iosb[2], retlen, keylen;
 811       register U32 hash;
 812
 813       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
 814       if (sts & 1) sts = iosb[0] & 0xffff;
 815       if (sts == SS$_ENDOFFILE) {
 816         int wakect = 0;
 817         while (substs == 0) { sys$hiber(); wakect++;}
 818         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
 819         _ckvmssts(substs);
 820         break;
 821       }
 822       _ckvmssts(sts);
 823       retlen = iosb[0] >> 16;
 824       if (!retlen) continue;  /* blank line */
 825       buf[retlen] = '\0';
 826       if (iosb[1] != subpid) {
 827         if (iosb[1]) {
 828           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
 829         }
 830         continue;
 831       }
 832       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
 833         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
 834
 835       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
 836       if (*cp1 == '(' || /* Logical name table name */
 837           *cp1 == '='    /* Next eqv of searchlist  */) continue;
 838       if (*cp1 == '"') cp1++;
 839       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
 840       key = cp1;  keylen = cp2 - cp1;
 841       if (keylen && hv_exists(seenhv,key,keylen)) continue;
 842       while (*cp2 && *cp2 != '=') cp2++;
 843       while (*cp2 && *cp2 == '=') cp2++;
 844       while (*cp2 && *cp2 == ' ') cp2++;
 845       if (*cp2 == '"') {  /* String translation; may embed "" */
 846         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
 847         cp2++;  cp1--; /* Skip "" surrounding translation */
 848       }
 849       else {  /* Numeric translation */
 850         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
 851         cp1--;  /* stop on last non-space char */
 852       }
 853       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
 854         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
 855         continue;
 856       }
 857       PERL_HASH(hash,key,keylen);
 858
 859       if (cp1 == cp2 && *cp2 == '.') {
 860         /* A single dot usually means an unprintable character, such as a null
 861          * to indicate a zero-length value.  Get the actual value to make sure.
 862          */
 863         char lnm[LNM$C_NAMLENGTH+1];
 864         char eqv[MAX_DCL_SYMBOL+1];
 865         strncpy(lnm, key, keylen);
 866         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
 867         sv = newSVpvn(eqv, strlen(eqv));
 868       }
 869       else {
 870         sv = newSVpvn(cp2,cp1 - cp2 + 1);
 871       }
 872
 873       SvTAINTED_on(sv);
 874       hv_store(envhv,key,keylen,sv,hash);
 875       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
 876     }
 877     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
 878       /* get the PPFs for this process, not the subprocess */
 879       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
 880       char eqv[LNM$C_NAMLENGTH+1];
 881       int trnlen, i;
 882       for (i = 0; ppfs[i]; i++) {
 883         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
 884         sv = newSVpv(eqv,trnlen);
 885         SvTAINTED_on(sv);
 886         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
 887       }
 888     }
 889   }
 890   primed = 1;
 891   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
 892   if (buf) Safefree(buf);
 893   if (seenhv) SvREFCNT_dec(seenhv);
 894   MUTEX_UNLOCK(&primenv_mutex);
 895   return;
 896
 897 }  /* end of prime_env_iter */
 898 /*}}}*/
 899
 900
 901 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
 902 /* Define or delete an element in the same "environment" as
 903  * vmstrnenv().  If an element is to be deleted, it's removed from
 904  * the first place it's found.  If it's to be set, it's set in the
 905  * place designated by the first element of the table vector.
 906  * Like setenv() returns 0 for success, non-zero on error.
 907  */
 908 int
 909 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
 910 {
 911     const char *cp1;
 912     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
 913     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
 914     int nseg = 0, j;
 915     unsigned long int retsts, usermode = PSL$C_USER;
 916     struct itmlst_3 *ile, *ilist;
 917     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 918                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 919                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 920     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 921     $DESCRIPTOR(local,"_LOCAL");
 922
 923     if (!lnm) {
 924         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 925         return SS$_IVLOGNAM;
 926     }
 927
 928     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 929       *cp2 = _toupper(*cp1);
 930       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 931         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 932         return SS$_IVLOGNAM;
 933       }
 934     }
 935     lnmdsc.dsc$w_length = cp1 - lnm;
 936     if (!tabvec || !*tabvec) tabvec = env_tables;
 937
 938     if (!eqv) {  /* we're deleting n element */
 939       for (curtab = 0; tabvec[curtab]; curtab++) {
 940         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 941         int i;
 942           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
 943             if ((cp1 = strchr(environ[i],'=')) &&
 944                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
 945                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
 946 #ifdef HAS_SETENV
 947               return setenv(lnm,"",1) ? vaxc$errno : 0;
 948             }
 949           }
 950           ivenv = 1; retsts = SS$_NOLOGNAM;
 951 #else
 952               if (ckWARN(WARN_INTERNAL))
 953                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
 954               ivenv = 1; retsts = SS$_NOSUCHPGM;
 955               break;
 956             }
 957           }
 958 #endif
 959         }
 960         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 961                  !str$case_blind_compare(&tmpdsc,&clisym)) {
 962           unsigned int symtype;
 963           if (tabvec[curtab]->dsc$w_length == 12 &&
 964               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
 965               !str$case_blind_compare(&tmpdsc,&local))
 966             symtype = LIB$K_CLI_LOCAL_SYM;
 967           else symtype = LIB$K_CLI_GLOBAL_SYM;
 968           retsts = lib$delete_symbol(&lnmdsc,&symtype);
 969           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 970           if (retsts == LIB$_NOSUCHSYM) continue;
 971           break;
 972         }
 973         else if (!ivlnm) {
 974           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
 975           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 976           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 977           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
 978           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 979         }
 980       }
 981     }
 982     else {  /* we're defining a value */
 983       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
 984 #ifdef HAS_SETENV
 985         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 986 #else
 987         if (ckWARN(WARN_INTERNAL))
 988           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
 989         retsts = SS$_NOSUCHPGM;
 990 #endif
 991       }
 992       else {
 993         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
 994         eqvdsc.dsc$w_length  = strlen(eqv);
 995         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
 996             !str$case_blind_compare(&tmpdsc,&clisym)) {
 997           unsigned int symtype;
 998           if (tabvec[0]->dsc$w_length == 12 &&
 999               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1000                !str$case_blind_compare(&tmpdsc,&local))
1001             symtype = LIB$K_CLI_LOCAL_SYM;
1002           else symtype = LIB$K_CLI_GLOBAL_SYM;
1003           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1004         }
1005         else {
1006           if (!*eqv) eqvdsc.dsc$w_length = 1;
1007           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1008
1009             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1010             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1011               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1012                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1013               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1014               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1015             }
1016
1017             Newx(ilist,nseg+1,struct itmlst_3);
1018             ile = ilist;
1019             if (!ile) {
1020               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1021               return SS$_INSFMEM;
1022             }
1023             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1024
1025             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1026               ile->itmcode = LNM$_STRING;
1027               ile->bufadr = c;
1028               if ((j+1) == nseg) {
1029                 ile->buflen = strlen(c);
1030                 /* in case we are truncating one that's too long */
1031                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1032               }
1033               else {
1034                 ile->buflen = LNM$C_NAMLENGTH;
1035               }
1036             }
1037
1038             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1039             Safefree (ilist);
1040           }
1041           else {
1042             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1043           }
1044         }
1045       }
1046     }
1047     if (!(retsts & 1)) {
1048       switch (retsts) {
1049         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1050         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1051           set_errno(EVMSERR); break;
1052         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1053         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1054           set_errno(EINVAL); break;
1055         case SS$_NOPRIV:
1056           set_errno(EACCES);
1057         default:
1058           _ckvmssts(retsts);
1059           set_errno(EVMSERR);
1060        }
1061        set_vaxc_errno(retsts);
1062        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1063     }
1064     else {
1065       /* We reset error values on success because Perl does an hv_fetch()
1066        * before each hv_store(), and if the thing we're setting didn't
1067        * previously exist, we've got a leftover error message.  (Of course,
1068        * this fails in the face of
1069        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1070        * in that the error reported in $! isn't spurious,
1071        * but it's right more often than not.)
1072        */
1073       set_errno(0); set_vaxc_errno(retsts);
1074       return 0;
1075     }
1076
1077 }  /* end of vmssetenv() */
1078 /*}}}*/
1079
1080 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1081 /* This has to be a function since there's a prototype for it in proto.h */
1082 void
1083 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1084 {
1085     if (lnm && *lnm) {
1086       int len = strlen(lnm);
1087       if  (len == 7) {
1088         char uplnm[8];
1089         int i;
1090         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1091         if (!strcmp(uplnm,"DEFAULT")) {
1092           if (eqv && *eqv) my_chdir(eqv);
1093           return;
1094         }
1095     }
1096 #ifndef RTL_USES_UTC
1097     if (len == 6 || len == 2) {
1098       char uplnm[7];
1099       int i;
1100       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1101       uplnm[len] = '\0';
1102       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1103       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1104     }
1105 #endif
1106   }
1107   (void) vmssetenv(lnm,eqv,NULL);
1108 }
1109 /*}}}*/
1110
1111 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1112 /*  vmssetuserlnm
1113  *  sets a user-mode logical in the process logical name table
1114  *  used for redirection of sys$error
1115  */
1116 void
1117 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1118 {
1119     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1120     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1121     unsigned long int iss, attr = LNM$M_CONFINE;
1122     unsigned char acmode = PSL$C_USER;
1123     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1124                                  {0, 0, 0, 0}};
1125     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1126     d_name.dsc$w_length = strlen(name);
1127
1128     lnmlst[0].buflen = strlen(eqv);
1129     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1130
1131     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1132     if (!(iss&1)) lib$signal(iss);
1133 }
1134 /*}}}*/
1135
1136
1137 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1138 /* my_crypt - VMS password hashing
1139  * my_crypt() provides an interface compatible with the Unix crypt()
1140  * C library function, and uses sys$hash_password() to perform VMS
1141  * password hashing.  The quadword hashed password value is returned
1142  * as a NUL-terminated 8 character string.  my_crypt() does not change
1143  * the case of its string arguments; in order to match the behavior
1144  * of LOGINOUT et al., alphabetic characters in both arguments must
1145  *  be upcased by the caller.
1146  *
1147  * - fix me to call ACM services when available
1148  */
1149 char *
1150 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1151 {
1152 #   ifndef UAI$C_PREFERRED_ALGORITHM
1153 #     define UAI$C_PREFERRED_ALGORITHM 127
1154 #   endif
1155     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1156     unsigned short int salt = 0;
1157     unsigned long int sts;
1158     struct const_dsc {
1159         unsigned short int dsc$w_length;
1160         unsigned char      dsc$b_type;
1161         unsigned char      dsc$b_class;
1162         const char *       dsc$a_pointer;
1163     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1164        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1165     struct itmlst_3 uailst[3] = {
1166         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1167         { sizeof salt, UAI$_SALT,    &salt, 0},
1168         { 0,           0,            NULL,  NULL}};
1169     static char hash[9];
1170
1171     usrdsc.dsc$w_length = strlen(usrname);
1172     usrdsc.dsc$a_pointer = usrname;
1173     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1174       switch (sts) {
1175         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1176           set_errno(EACCES);
1177           break;
1178         case RMS$_RNF:
1179           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1180           break;
1181         default:
1182           set_errno(EVMSERR);
1183       }
1184       set_vaxc_errno(sts);
1185       if (sts != RMS$_RNF) return NULL;
1186     }
1187
1188     txtdsc.dsc$w_length = strlen(textpasswd);
1189     txtdsc.dsc$a_pointer = textpasswd;
1190     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1191       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1192     }
1193
1194     return (char *) hash;
1195
1196 }  /* end of my_crypt() */
1197 /*}}}*/
1198
1199
1200 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1201 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1202 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1203
1204 /* fixup barenames that are directories for internal use.
1205  * There have been problems with the consistent handling of UNIX
1206  * style directory names when routines are presented with a name that
1207  * has no directory delimitors at all.  So this routine will eventually
1208  * fix the issue.
1209  */
1210 static char * fixup_bare_dirnames(const char * name)
1211 {
1212   if (decc_disable_to_vms_logname_translation) {
1213 /* fix me */
1214   }
1215   return NULL;
1216 }
1217
1218 /* mp_do_kill_file
1219  * A little hack to get around a bug in some implemenation of remove()
1220  * that do not know how to delete a directory
1221  *
1222  * Delete any file to which user has control access, regardless of whether
1223  * delete access is explicitly allowed.
1224  * Limitations: User must have write access to parent directory.
1225  *              Does not block signals or ASTs; if interrupted in midstream
1226  *              may leave file with an altered ACL.
1227  * HANDLE WITH CARE!
1228  */
1229 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1230 static int
1231 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1232 {
1233     char *vmsname, *rspec;
1234     char *remove_name;
1235     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1236     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1237     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1238     struct myacedef {
1239       unsigned char myace$b_length;
1240       unsigned char myace$b_type;
1241       unsigned short int myace$w_flags;
1242       unsigned long int myace$l_access;
1243       unsigned long int myace$l_ident;
1244     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1245                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1246       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1247      struct itmlst_3
1248        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1249                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1250        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1251        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1252        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1253        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1254
1255     /* Expand the input spec using RMS, since the CRTL remove() and
1256      * system services won't do this by themselves, so we may miss
1257      * a file "hiding" behind a logical name or search list. */
1258     Newx(vmsname, NAM$C_MAXRSS+1, char);
1259     if (do_tovmsspec(name,vmsname,0) == NULL) {
1260       Safefree(vmsname);
1261       return -1;
1262     }
1263
1264     if (decc_posix_compliant_pathnames) {
1265       /* In POSIX mode, we prefer to remove the UNIX name */
1266       rspec = vmsname;
1267       remove_name = (char *)name;
1268     }
1269     else {
1270       Newx(rspec, NAM$C_MAXRSS+1, char);
1271       if (do_rmsexpand(vmsname, rspec, 1, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1272         Safefree(rspec);
1273         Safefree(vmsname);
1274         return -1;
1275       }
1276       Safefree(vmsname);
1277       remove_name = rspec;
1278     }
1279
1280 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1281     if (dirflag != 0) {
1282         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1283           Newx(remove_name, NAM$C_MAXRSS+1, char);
1284           do_pathify_dirspec(name, remove_name, 0);
1285           if (!rmdir(remove_name)) {
1286
1287             Safefree(remove_name);
1288             Safefree(rspec);
1289             return 0;   /* Can we just get rid of it? */
1290           }
1291         }
1292         else {
1293           if (!rmdir(remove_name)) {
1294             Safefree(rspec);
1295             return 0;   /* Can we just get rid of it? */
1296           }
1297         }
1298     }
1299     else
1300 #endif
1301       if (!remove(remove_name)) {
1302         Safefree(rspec);
1303         return 0;   /* Can we just get rid of it? */
1304       }
1305
1306     /* If not, can changing protections help? */
1307     if (vaxc$errno != RMS$_PRV) {
1308       Safefree(rspec);
1309       return -1;
1310     }
1311
1312     /* No, so we get our own UIC to use as a rights identifier,
1313      * and the insert an ACE at the head of the ACL which allows us
1314      * to delete the file.
1315      */
1316     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1317     fildsc.dsc$w_length = strlen(rspec);
1318     fildsc.dsc$a_pointer = rspec;
1319     cxt = 0;
1320     newace.myace$l_ident = oldace.myace$l_ident;
1321     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1322       switch (aclsts) {
1323         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1324           set_errno(ENOENT); break;
1325         case RMS$_DIR:
1326           set_errno(ENOTDIR); break;
1327         case RMS$_DEV:
1328           set_errno(ENODEV); break;
1329         case RMS$_SYN: case SS$_INVFILFOROP:
1330           set_errno(EINVAL); break;
1331         case RMS$_PRV:
1332           set_errno(EACCES); break;
1333         default:
1334           _ckvmssts(aclsts);
1335       }
1336       set_vaxc_errno(aclsts);
1337       Safefree(rspec);
1338       return -1;
1339     }
1340     /* Grab any existing ACEs with this identifier in case we fail */
1341     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1342     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1343                     || fndsts == SS$_NOMOREACE ) {
1344       /* Add the new ACE . . . */
1345       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1346         goto yourroom;
1347
1348 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1349       if (dirflag != 0)
1350         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1351           Newx(remove_name, NAM$C_MAXRSS+1, char);
1352           do_pathify_dirspec(name, remove_name, 0);
1353           rmsts = rmdir(remove_name);
1354           Safefree(remove_name);
1355         }
1356         else {
1357         rmsts = rmdir(remove_name);
1358         }
1359       else
1360 #endif
1361         rmsts = remove(remove_name);
1362       if (rmsts) {
1363         /* We blew it - dir with files in it, no write priv for
1364          * parent directory, etc.  Put things back the way they were. */
1365         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1366           goto yourroom;
1367         if (fndsts & 1) {
1368           addlst[0].bufadr = &oldace;
1369           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1370             goto yourroom;
1371         }
1372       }
1373     }
1374
1375     yourroom:
1376     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1377     /* We just deleted it, so of course it's not there.  Some versions of
1378      * VMS seem to return success on the unlock operation anyhow (after all
1379      * the unlock is successful), but others don't.
1380      */
1381     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1382     if (aclsts & 1) aclsts = fndsts;
1383     if (!(aclsts & 1)) {
1384       set_errno(EVMSERR);
1385       set_vaxc_errno(aclsts);
1386       Safefree(rspec);
1387       return -1;
1388     }
1389
1390     Safefree(rspec);
1391     return rmsts;
1392
1393 }  /* end of kill_file() */
1394 /*}}}*/
1395
1396
1397 /*{{{int do_rmdir(char *name)*/
1398 int
1399 Perl_do_rmdir(pTHX_ const char *name)
1400 {
1401     char dirfile[NAM$C_MAXRSS+1];
1402     int retval;
1403     Stat_t st;
1404
1405     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1406     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1407     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1408     return retval;
1409
1410 }  /* end of do_rmdir */
1411 /*}}}*/
1412
1413 /* kill_file
1414  * Delete any file to which user has control access, regardless of whether
1415  * delete access is explicitly allowed.
1416  * Limitations: User must have write access to parent directory.
1417  *              Does not block signals or ASTs; if interrupted in midstream
1418  *              may leave file with an altered ACL.
1419  * HANDLE WITH CARE!
1420  */
1421 /*{{{int kill_file(char *name)*/
1422 int
1423 Perl_kill_file(pTHX_ const char *name)
1424 {
1425     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1426     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1427     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1428     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1429     struct myacedef {
1430       unsigned char myace$b_length;
1431       unsigned char myace$b_type;
1432       unsigned short int myace$w_flags;
1433       unsigned long int myace$l_access;
1434       unsigned long int myace$l_ident;
1435     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1436                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1437       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1438      struct itmlst_3
1439        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1440                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1441        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1442        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1443        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1444        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1445
1446     /* Expand the input spec using RMS, since the CRTL remove() and
1447      * system services won't do this by themselves, so we may miss
1448      * a file "hiding" behind a logical name or search list. */
1449     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1450     if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1451     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1452     /* If not, can changing protections help? */
1453     if (vaxc$errno != RMS$_PRV) return -1;
1454
1455     /* No, so we get our own UIC to use as a rights identifier,
1456      * and the insert an ACE at the head of the ACL which allows us
1457      * to delete the file.
1458      */
1459     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1460     fildsc.dsc$w_length = strlen(rspec);
1461     fildsc.dsc$a_pointer = rspec;
1462     cxt = 0;
1463     newace.myace$l_ident = oldace.myace$l_ident;
1464     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1465       switch (aclsts) {
1466         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1467           set_errno(ENOENT); break;
1468         case RMS$_DIR:
1469           set_errno(ENOTDIR); break;
1470         case RMS$_DEV:
1471           set_errno(ENODEV); break;
1472         case RMS$_SYN: case SS$_INVFILFOROP:
1473           set_errno(EINVAL); break;
1474         case RMS$_PRV:
1475           set_errno(EACCES); break;
1476         default:
1477           _ckvmssts(aclsts);
1478       }
1479       set_vaxc_errno(aclsts);
1480       return -1;
1481     }
1482     /* Grab any existing ACEs with this identifier in case we fail */
1483     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1484     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1485                     || fndsts == SS$_NOMOREACE ) {
1486       /* Add the new ACE . . . */
1487       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1488         goto yourroom;
1489       if ((rmsts = remove(name))) {
1490         /* We blew it - dir with files in it, no write priv for
1491          * parent directory, etc.  Put things back the way they were. */
1492         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1493           goto yourroom;
1494         if (fndsts & 1) {
1495           addlst[0].bufadr = &oldace;
1496           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1497             goto yourroom;
1498         }
1499       }
1500     }
1501
1502     yourroom:
1503     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1504     /* We just deleted it, so of course it's not there.  Some versions of
1505      * VMS seem to return success on the unlock operation anyhow (after all
1506      * the unlock is successful), but others don't.
1507      */
1508     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1509     if (aclsts & 1) aclsts = fndsts;
1510     if (!(aclsts & 1)) {
1511       set_errno(EVMSERR);
1512       set_vaxc_errno(aclsts);
1513       return -1;
1514     }
1515
1516     return rmsts;
1517
1518 }  /* end of kill_file() */
1519 /*}}}*/
1520
1521
1522 /*{{{int my_mkdir(char *,Mode_t)*/
1523 int
1524 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1525 {
1526   STRLEN dirlen = strlen(dir);
1527
1528   /* zero length string sometimes gives ACCVIO */
1529   if (dirlen == 0) return -1;
1530
1531   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1532    * null file name/type.  However, it's commonplace under Unix,
1533    * so we'll allow it for a gain in portability.
1534    */
1535   if (dir[dirlen-1] == '/') {
1536     char *newdir = savepvn(dir,dirlen-1);
1537     int ret = mkdir(newdir,mode);
1538     Safefree(newdir);
1539     return ret;
1540   }
1541   else return mkdir(dir,mode);
1542 }  /* end of my_mkdir */
1543 /*}}}*/
1544
1545 /*{{{int my_chdir(char *)*/
1546 int
1547 Perl_my_chdir(pTHX_ const char *dir)
1548 {
1549   STRLEN dirlen = strlen(dir);
1550
1551   /* zero length string sometimes gives ACCVIO */
1552   if (dirlen == 0) return -1;
1553   const char *dir1;
1554
1555   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1556    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
1557    * so that existing scripts do not need to be changed.
1558    */
1559   dir1 = dir;
1560   while ((dirlen > 0) && (*dir1 == ' ')) {
1561     dir1++;
1562     dirlen--;
1563   }
1564
1565   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1566    * that implies
1567    * null file name/type.  However, it's commonplace under Unix,
1568    * so we'll allow it for a gain in portability.
1569    *
1570    * - Preview- '/' will be valid soon on VMS
1571    */
1572   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1573     char *newdir = savepvn(dir,dirlen-1);
1574     int ret = chdir(newdir);
1575     Safefree(newdir);
1576     return ret;
1577   }
1578   else return chdir(dir);
1579 }  /* end of my_chdir */
1580 /*}}}*/
1581
1582
1583 /*{{{FILE *my_tmpfile()*/
1584 FILE *
1585 my_tmpfile(void)
1586 {
1587   FILE *fp;
1588   char *cp;
1589
1590   if ((fp = tmpfile())) return fp;
1591
1592   Newx(cp,L_tmpnam+24,char);
1593   if (decc_filename_unix_only == 0)
1594     strcpy(cp,"Sys$Scratch:");
1595   else
1596     strcpy(cp,"/tmp/");
1597   tmpnam(cp+strlen(cp));
1598   strcat(cp,".Perltmp");
1599   fp = fopen(cp,"w+","fop=dlt");
1600   Safefree(cp);
1601   return fp;
1602 }
1603 /*}}}*/
1604
1605
1606 #ifndef HOMEGROWN_POSIX_SIGNALS
1607 /*
1608  * The C RTL's sigaction fails to check for invalid signal numbers so we
1609  * help it out a bit.  The docs are correct, but the actual routine doesn't
1610  * do what the docs say it will.
1611  */
1612 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1613 int
1614 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1615                    struct sigaction* oact)
1616 {
1617   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1618         SETERRNO(EINVAL, SS$_INVARG);
1619         return -1;
1620   }
1621   return sigaction(sig, act, oact);
1622 }
1623 /*}}}*/
1624 #endif
1625
1626 #ifdef KILL_BY_SIGPRC
1627 #include <errnodef.h>
1628
1629 /* We implement our own kill() using the undocumented system service
1630    sys$sigprc for one of two reasons:
1631
1632    1.) If the kill() in an older CRTL uses sys$forcex, causing the
1633    target process to do a sys$exit, which usually can't be handled
1634    gracefully...certainly not by Perl and the %SIG{} mechanism.
1635
1636    2.) If the kill() in the CRTL can't be called from a signal
1637    handler without disappearing into the ether, i.e., the signal
1638    it purportedly sends is never trapped. Still true as of VMS 7.3.
1639
1640    sys$sigprc has the same parameters as sys$forcex, but throws an exception
1641    in the target process rather than calling sys$exit.
1642
1643    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1644    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1645    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
1646    with condition codes C$_SIG0+nsig*8, catching the exception on the
1647    target process and resignaling with appropriate arguments.
1648
1649    But we don't have that VMS 7.0+ exception handler, so if you
1650    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
1651
1652    Also note that SIGTERM is listed in the docs as being "unimplemented",
1653    yet always seems to be signaled with a VMS condition code of 4 (and
1654    correctly handled for that code).  So we hardwire it in.
1655
1656    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1657    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
1658    than signalling with an unrecognized (and unhandled by CRTL) code.
1659 */
1660
1661 #define _MY_SIG_MAX 17
1662
1663 unsigned int
1664 Perl_sig_to_vmscondition(int sig)
1665 {
1666     static unsigned int sig_code[_MY_SIG_MAX+1] =
1667     {
1668         0,                  /*  0 ZERO     */
1669         SS$_HANGUP,         /*  1 SIGHUP   */
1670         SS$_CONTROLC,       /*  2 SIGINT   */
1671         SS$_CONTROLY,       /*  3 SIGQUIT  */
1672         SS$_RADRMOD,        /*  4 SIGILL   */
1673         SS$_BREAK,          /*  5 SIGTRAP  */
1674         SS$_OPCCUS,         /*  6 SIGABRT  */
1675         SS$_COMPAT,         /*  7 SIGEMT   */
1676 #ifdef __VAX
1677         SS$_FLTOVF,         /*  8 SIGFPE VAX */
1678 #else
1679         SS$_HPARITH,        /*  8 SIGFPE AXP */
1680 #endif
1681         SS$_ABORT,          /*  9 SIGKILL  */
1682         SS$_ACCVIO,         /* 10 SIGBUS   */
1683         SS$_ACCVIO,         /* 11 SIGSEGV  */
1684         SS$_BADPARAM,       /* 12 SIGSYS   */
1685         SS$_NOMBX,          /* 13 SIGPIPE  */
1686         SS$_ASTFLT,         /* 14 SIGALRM  */
1687         4,                  /* 15 SIGTERM  */
1688         0,                  /* 16 SIGUSR1  */
1689         0                   /* 17 SIGUSR2  */
1690     };
1691
1692 #if __VMS_VER >= 60200000
1693     static int initted = 0;
1694     if (!initted) {
1695         initted = 1;
1696         sig_code[16] = C$_SIGUSR1;
1697         sig_code[17] = C$_SIGUSR2;
1698     }
1699 #endif
1700
1701     if (sig < _SIG_MIN) return 0;
1702     if (sig > _MY_SIG_MAX) return 0;
1703     return sig_code[sig];
1704 }
1705
1706 int
1707 Perl_my_kill(int pid, int sig)
1708 {
1709     dTHX;
1710     int iss;
1711     unsigned int code;
1712     int sys$sigprc(unsigned int *pidadr,
1713                      struct dsc$descriptor_s *prcname,
1714                      unsigned int code);
1715
1716      /* sig 0 means validate the PID */
1717     /*------------------------------*/
1718     if (sig == 0) {
1719         const unsigned long int jpicode = JPI$_PID;
1720         pid_t ret_pid;
1721         int status;
1722         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
1723         if ($VMS_STATUS_SUCCESS(status))
1724            return 0;
1725         switch (status) {
1726         case SS$_NOSUCHNODE:
1727         case SS$_UNREACHABLE:
1728         case SS$_NONEXPR:
1729            errno = ESRCH;
1730            break;
1731         case SS$_NOPRIV:
1732            errno = EPERM;
1733            break;
1734         default:
1735            errno = EVMSERR;
1736         }
1737         vaxc$errno=status;
1738         return -1;
1739     }
1740
1741     code = Perl_sig_to_vmscondition(sig);
1742
1743     if (!code) {
1744         SETERRNO(EINVAL, SS$_BADPARAM);
1745         return -1;
1746     }
1747
1748     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
1749      * signals are to be sent to multiple processes.
1750      *  pid = 0 - all processes in group except ones that the system exempts
1751      *  pid = -1 - all processes except ones that the system exempts
1752      *  pid = -n - all processes in group (abs(n)) except ...
1753      * For now, just report as not supported.
1754      */
1755
1756     if (pid <= 0) {
1757         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
1758         return -1;
1759     }
1760
1761     iss = sys$sigprc((unsigned int *)&pid,0,code);
1762     if (iss&1) return 0;
1763
1764     switch (iss) {
1765       case SS$_NOPRIV:
1766         set_errno(EPERM);  break;
1767       case SS$_NONEXPR:
1768       case SS$_NOSUCHNODE:
1769       case SS$_UNREACHABLE:
1770         set_errno(ESRCH);  break;
1771       case SS$_INSFMEM:
1772         set_errno(ENOMEM); break;
1773       default:
1774         _ckvmssts(iss);
1775         set_errno(EVMSERR);
1776     }
1777     set_vaxc_errno(iss);
1778
1779     return -1;
1780 }
1781 #endif
1782
1783 /* Routine to convert a VMS status code to a UNIX status code.
1784 ** More tricky than it appears because of conflicting conventions with
1785 ** existing code.
1786 **
1787 ** VMS status codes are a bit mask, with the least significant bit set for
1788 ** success.
1789 **
1790 ** Special UNIX status of EVMSERR indicates that no translation is currently
1791 ** available, and programs should check the VMS status code.
1792 **
1793 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
1794 ** decoding.
1795 */
1796
1797 #ifndef C_FACILITY_NO
1798 #define C_FACILITY_NO 0x350000
1799 #endif
1800 #ifndef DCL_IVVERB
1801 #define DCL_IVVERB 0x38090
1802 #endif
1803
1804 int Perl_vms_status_to_unix(int vms_status, int child_flag)
1805 {
1806 int facility;
1807 int fac_sp;
1808 int msg_no;
1809 int msg_status;
1810 int unix_status;
1811
1812   /* Assume the best or the worst */
1813   if (vms_status & STS$M_SUCCESS)
1814     unix_status = 0;
1815   else
1816     unix_status = EVMSERR;
1817
1818   msg_status = vms_status & ~STS$M_CONTROL;
1819
1820   facility = vms_status & STS$M_FAC_NO;
1821   fac_sp = vms_status & STS$M_FAC_SP;
1822   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
1823
1824   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
1825     switch(msg_no) {
1826     case SS$_NORMAL:
1827         unix_status = 0;
1828         break;
1829     case SS$_ACCVIO:
1830         unix_status = EFAULT;
1831         break;
1832     case SS$_DEVOFFLINE:
1833         unix_status = EBUSY;
1834         break;
1835     case SS$_CLEARED:
1836         unix_status = ENOTCONN;
1837         break;
1838     case SS$_IVCHAN:
1839     case SS$_IVLOGNAM:
1840     case SS$_BADPARAM:
1841     case SS$_IVLOGTAB:
1842     case SS$_NOLOGNAM:
1843     case SS$_NOLOGTAB:
1844     case SS$_INVFILFOROP:
1845     case SS$_INVARG:
1846     case SS$_NOSUCHID:
1847     case SS$_IVIDENT:
1848         unix_status = EINVAL;
1849         break;
1850     case SS$_UNSUPPORTED:
1851         unix_status = ENOTSUP;
1852         break;
1853     case SS$_FILACCERR:
1854     case SS$_NOGRPPRV:
1855     case SS$_NOSYSPRV:
1856         unix_status = EACCES;
1857         break;
1858     case SS$_DEVICEFULL:
1859         unix_status = ENOSPC;
1860         break;
1861     case SS$_NOSUCHDEV:
1862         unix_status = ENODEV;
1863         break;
1864     case SS$_NOSUCHFILE:
1865     case SS$_NOSUCHOBJECT:
1866         unix_status = ENOENT;
1867         break;
1868     case SS$_ABORT:                                 /* Fatal case */
1869     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
1870     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
1871         unix_status = EINTR;
1872         break;
1873     case SS$_BUFFEROVF:
1874         unix_status = E2BIG;
1875         break;
1876     case SS$_INSFMEM:
1877         unix_status = ENOMEM;
1878         break;
1879     case SS$_NOPRIV:
1880         unix_status = EPERM;
1881         break;
1882     case SS$_NOSUCHNODE:
1883     case SS$_UNREACHABLE:
1884         unix_status = ESRCH;
1885         break;
1886     case SS$_NONEXPR:
1887         unix_status = ECHILD;
1888         break;
1889     default:
1890         if ((facility == 0) && (msg_no < 8)) {
1891           /* These are not real VMS status codes so assume that they are
1892           ** already UNIX status codes
1893           */
1894           unix_status = msg_no;
1895           break;
1896         }
1897     }
1898   }
1899   else {
1900     /* Translate a POSIX exit code to a UNIX exit code */
1901     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
1902         unix_status = (msg_no & 0x07F8) >> 3;
1903     }
1904     else {
1905
1906          /* Documented traditional behavior for handling VMS child exits */
1907         /*--------------------------------------------------------------*/
1908         if (child_flag != 0) {
1909
1910              /* Success / Informational return 0 */
1911             /*----------------------------------*/
1912             if (msg_no & STS$K_SUCCESS)
1913                 return 0;
1914
1915              /* Warning returns 1 */
1916             /*-------------------*/
1917             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
1918                 return 1;
1919
1920              /* Everything else pass through the severity bits */
1921             /*------------------------------------------------*/
1922             return (msg_no & STS$M_SEVERITY);
1923         }
1924
1925          /* Normal VMS status to ERRNO mapping attempt */
1926         /*--------------------------------------------*/
1927         switch(msg_status) {
1928         /* case RMS$_EOF: */ /* End of File */
1929         case RMS$_FNF:  /* File Not Found */
1930         case RMS$_DNF:  /* Dir Not Found */
1931                 unix_status = ENOENT;
1932                 break;
1933         case RMS$_RNF:  /* Record Not Found */
1934                 unix_status = ESRCH;
1935                 break;
1936         case RMS$_DIR:
1937                 unix_status = ENOTDIR;
1938                 break;
1939         case RMS$_DEV:
1940                 unix_status = ENODEV;
1941                 break;
1942         case RMS$_IFI:
1943         case RMS$_FAC:
1944         case RMS$_ISI:
1945                 unix_status = EBADF;
1946                 break;
1947         case RMS$_FEX:
1948                 unix_status = EEXIST;
1949                 break;
1950         case RMS$_SYN:
1951         case RMS$_FNM:
1952         case LIB$_INVSTRDES:
1953         case LIB$_INVARG:
1954         case LIB$_NOSUCHSYM:
1955         case LIB$_INVSYMNAM:
1956         case DCL_IVVERB:
1957                 unix_status = EINVAL;
1958                 break;
1959         case CLI$_BUFOVF:
1960         case RMS$_RTB:
1961         case CLI$_TKNOVF:
1962         case CLI$_RSLOVF:
1963                 unix_status = E2BIG;
1964                 break;
1965         case RMS$_PRV:  /* No privilege */
1966         case RMS$_ACC:  /* ACP file access failed */
1967         case RMS$_WLK:  /* Device write locked */
1968                 unix_status = EACCES;
1969                 break;
1970         /* case RMS$_NMF: */  /* No more files */
1971         }
1972     }
1973   }
1974
1975   return unix_status;
1976 }
1977
1978 /* Try to guess at what VMS error status should go with a UNIX errno
1979  * value.  This is hard to do as there could be many possible VMS
1980  * error statuses that caused the errno value to be set.
1981  */
1982
1983 int Perl_unix_status_to_vms(int unix_status)
1984 {
1985 int test_unix_status;
1986
1987      /* Trivial cases first */
1988     /*---------------------*/
1989     if (unix_status == EVMSERR)
1990         return vaxc$errno;
1991
1992      /* Is vaxc$errno sane? */
1993     /*---------------------*/
1994     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
1995     if (test_unix_status == unix_status)
1996         return vaxc$errno;
1997
1998      /* If way out of range, must be VMS code already */
1999     /*-----------------------------------------------*/
2000     if (unix_status > EVMSERR)
2001         return unix_status;
2002
2003      /* If out of range, punt */
2004     /*-----------------------*/
2005     if (unix_status > __ERRNO_MAX)
2006         return SS$_ABORT;
2007
2008
2009      /* Ok, now we have to do it the hard way. */
2010     /*----------------------------------------*/
2011     switch(unix_status) {
2012     case 0:     return SS$_NORMAL;
2013     case EPERM: return SS$_NOPRIV;
2014     case ENOENT: return SS$_NOSUCHOBJECT;
2015     case ESRCH: return SS$_UNREACHABLE;
2016     case EINTR: return SS$_ABORT;
2017     /* case EIO: */
2018     /* case ENXIO:  */
2019     case E2BIG: return SS$_BUFFEROVF;
2020     /* case ENOEXEC */
2021     case EBADF: return RMS$_IFI;
2022     case ECHILD: return SS$_NONEXPR;
2023     /* case EAGAIN */
2024     case ENOMEM: return SS$_INSFMEM;
2025     case EACCES: return SS$_FILACCERR;
2026     case EFAULT: return SS$_ACCVIO;
2027     /* case ENOTBLK */
2028     case EBUSY: return SS$_DEVOFFLINE;
2029     case EEXIST: return RMS$_FEX;
2030     /* case EXDEV */
2031     case ENODEV: return SS$_NOSUCHDEV;
2032     case ENOTDIR: return RMS$_DIR;
2033     /* case EISDIR */
2034     case EINVAL: return SS$_INVARG;
2035     /* case ENFILE */
2036     /* case EMFILE */
2037     /* case ENOTTY */
2038     /* case ETXTBSY */
2039     /* case EFBIG */
2040     case ENOSPC: return SS$_DEVICEFULL;
2041     case ESPIPE: return LIB$_INVARG;
2042     /* case EROFS: */
2043     /* case EMLINK: */
2044     /* case EPIPE: */
2045     /* case EDOM */
2046     case ERANGE: return LIB$_INVARG;
2047     /* case EWOULDBLOCK */
2048     /* case EINPROGRESS */
2049     /* case EALREADY */
2050     /* case ENOTSOCK */
2051     /* case EDESTADDRREQ */
2052     /* case EMSGSIZE */
2053     /* case EPROTOTYPE */
2054     /* case ENOPROTOOPT */
2055     /* case EPROTONOSUPPORT */
2056     /* case ESOCKTNOSUPPORT */
2057     /* case EOPNOTSUPP */
2058     /* case EPFNOSUPPORT */
2059     /* case EAFNOSUPPORT */
2060     /* case EADDRINUSE */
2061     /* case EADDRNOTAVAIL */
2062     /* case ENETDOWN */
2063     /* case ENETUNREACH */
2064     /* case ENETRESET */
2065     /* case ECONNABORTED */
2066     /* case ECONNRESET */
2067     /* case ENOBUFS */
2068     /* case EISCONN */
2069     case ENOTCONN: return SS$_CLEARED;
2070     /* case ESHUTDOWN */
2071     /* case ETOOMANYREFS */
2072     /* case ETIMEDOUT */
2073     /* case ECONNREFUSED */
2074     /* case ELOOP */
2075     /* case ENAMETOOLONG */
2076     /* case EHOSTDOWN */
2077     /* case EHOSTUNREACH */
2078     /* case ENOTEMPTY */
2079     /* case EPROCLIM */
2080     /* case EUSERS  */
2081     /* case EDQUOT  */
2082     /* case ENOMSG  */
2083     /* case EIDRM */
2084     /* case EALIGN */
2085     /* case ESTALE */
2086     /* case EREMOTE */
2087     /* case ENOLCK */
2088     /* case ENOSYS */
2089     /* case EFTYPE */
2090     /* case ECANCELED */
2091     /* case EFAIL */
2092     /* case EINPROG */
2093     case ENOTSUP:
2094         return SS$_UNSUPPORTED;
2095     /* case EDEADLK */
2096     /* case ENWAIT */
2097     /* case EILSEQ */
2098     /* case EBADCAT */
2099     /* case EBADMSG */
2100     /* case EABANDONED */
2101     default:
2102         return SS$_ABORT; /* punt */
2103     }
2104
2105   return SS$_ABORT; /* Should not get here */
2106 }
2107
2108
2109 /* default piping mailbox size */
2110 #define PERL_BUFSIZ        512
2111
2112
2113 static void
2114 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2115 {
2116   unsigned long int mbxbufsiz;
2117   static unsigned long int syssize = 0;
2118   unsigned long int dviitm = DVI$_DEVNAM;
2119   char csize[LNM$C_NAMLENGTH+1];
2120   int sts;
2121
2122   if (!syssize) {
2123     unsigned long syiitm = SYI$_MAXBUF;
2124     /*
2125      * Get the SYSGEN parameter MAXBUF
2126      *
2127      * If the logical 'PERL_MBX_SIZE' is defined
2128      * use the value of the logical instead of PERL_BUFSIZ, but
2129      * keep the size between 128 and MAXBUF.
2130      *
2131      */
2132     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2133   }
2134
2135   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2136       mbxbufsiz = atoi(csize);
2137   } else {
2138       mbxbufsiz = PERL_BUFSIZ;
2139   }
2140   if (mbxbufsiz < 128) mbxbufsiz = 128;
2141   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2142
2143   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2144
2145   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2146   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2147
2148 }  /* end of create_mbx() */
2149
2150
2151 /*{{{  my_popen and my_pclose*/
2152
2153 typedef struct _iosb           IOSB;
2154 typedef struct _iosb*         pIOSB;
2155 typedef struct _pipe           Pipe;
2156 typedef struct _pipe*         pPipe;
2157 typedef struct pipe_details    Info;
2158 typedef struct pipe_details*  pInfo;
2159 typedef struct _srqp            RQE;
2160 typedef struct _srqp*          pRQE;
2161 typedef struct _tochildbuf      CBuf;
2162 typedef struct _tochildbuf*    pCBuf;
2163
2164 struct _iosb {
2165     unsigned short status;
2166     unsigned short count;
2167     unsigned long  dvispec;
2168 };
2169
2170 #pragma member_alignment save
2171 #pragma nomember_alignment quadword
2172 struct _srqp {          /* VMS self-relative queue entry */
2173     unsigned long qptr[2];
2174 };
2175 #pragma member_alignment restore
2176 static RQE  RQE_ZERO = {0,0};
2177
2178 struct _tochildbuf {
2179     RQE             q;
2180     int             eof;
2181     unsigned short  size;
2182     char            *buf;
2183 };
2184
2185 struct _pipe {
2186     RQE            free;
2187     RQE            wait;
2188     int            fd_out;
2189     unsigned short chan_in;
2190     unsigned short chan_out;
2191     char          *buf;
2192     unsigned int   bufsize;
2193     IOSB           iosb;
2194     IOSB           iosb2;
2195     int           *pipe_done;
2196     int            retry;
2197     int            type;
2198     int            shut_on_empty;
2199     int            need_wake;
2200     pPipe         *home;
2201     pInfo          info;
2202     pCBuf          curr;
2203     pCBuf          curr2;
2204 #if defined(PERL_IMPLICIT_CONTEXT)
2205     void            *thx;           /* Either a thread or an interpreter */
2206                                     /* pointer, depending on how we're built */
2207 #endif
2208 };
2209
2210
2211 struct pipe_details
2212 {
2213     pInfo           next;
2214     PerlIO *fp;  /* file pointer to pipe mailbox */
2215     int useFILE; /* using stdio, not perlio */
2216     int pid;   /* PID of subprocess */
2217     int mode;  /* == 'r' if pipe open for reading */
2218     int done;  /* subprocess has completed */
2219     int waiting; /* waiting for completion/closure */
2220     int             closing;        /* my_pclose is closing this pipe */
2221     unsigned long   completion;     /* termination status of subprocess */
2222     pPipe           in;             /* pipe in to sub */
2223     pPipe           out;            /* pipe out of sub */
2224     pPipe           err;            /* pipe of sub's sys$error */
2225     int             in_done;        /* true when in pipe finished */
2226     int             out_done;
2227     int             err_done;
2228 };
2229
2230 struct exit_control_block
2231 {
2232     struct exit_control_block *flink;
2233     unsigned long int   (*exit_routine)();
2234     unsigned long int arg_count;
2235     unsigned long int *status_address;
2236     unsigned long int exit_status;
2237 };
2238
2239 typedef struct _closed_pipes    Xpipe;
2240 typedef struct _closed_pipes*  pXpipe;
2241
2242 struct _closed_pipes {
2243     int             pid;            /* PID of subprocess */
2244     unsigned long   completion;     /* termination status of subprocess */
2245 };
2246 #define NKEEPCLOSED 50
2247 static Xpipe closed_list[NKEEPCLOSED];
2248 static int   closed_index = 0;
2249 static int   closed_num = 0;
2250
2251 #define RETRY_DELAY     "0 ::0.20"
2252 #define MAX_RETRY              50
2253
2254 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2255 static unsigned long mypid;
2256 static unsigned long delaytime[2];
2257
2258 static pInfo open_pipes = NULL;
2259 static $DESCRIPTOR(nl_desc, "NL:");
2260
2261 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2262
2263
2264
2265 static unsigned long int
2266 pipe_exit_routine(pTHX)
2267 {
2268     pInfo info;
2269     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2270     int sts, did_stuff, need_eof, j;
2271
2272     /*
2273         flush any pending i/o
2274     */
2275     info = open_pipes;
2276     while (info) {
2277         if (info->fp) {
2278            if (!info->useFILE)
2279                PerlIO_flush(info->fp);   /* first, flush data */
2280            else
2281                fflush((FILE *)info->fp);
2282         }
2283         info = info->next;
2284     }
2285
2286     /*
2287      next we try sending an EOF...ignore if doesn't work, make sure we
2288      don't hang
2289     */
2290     did_stuff = 0;
2291     info = open_pipes;
2292
2293     while (info) {
2294       int need_eof;
2295       _ckvmssts(sys$setast(0));
2296       if (info->in && !info->in->shut_on_empty) {
2297         _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2298                           0, 0, 0, 0, 0, 0));
2299         info->waiting = 1;
2300         did_stuff = 1;
2301       }
2302       _ckvmssts(sys$setast(1));
2303       info = info->next;
2304     }
2305
2306     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2307
2308     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2309         int nwait = 0;
2310
2311         info = open_pipes;
2312         while (info) {
2313           _ckvmssts(sys$setast(0));
2314           if (info->waiting && info->done)
2315                 info->waiting = 0;
2316           nwait += info->waiting;
2317           _ckvmssts(sys$setast(1));
2318           info = info->next;
2319         }
2320         if (!nwait) break;
2321         sleep(1);
2322     }
2323
2324     did_stuff = 0;
2325     info = open_pipes;
2326     while (info) {
2327       _ckvmssts(sys$setast(0));
2328       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2329         sts = sys$forcex(&info->pid,0,&abort);
2330         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
2331         did_stuff = 1;
2332       }
2333       _ckvmssts(sys$setast(1));
2334       info = info->next;
2335     }
2336
2337     /* again, wait for effect */
2338
2339     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2340         int nwait = 0;
2341
2342         info = open_pipes;
2343         while (info) {
2344           _ckvmssts(sys$setast(0));
2345           if (info->waiting && info->done)
2346                 info->waiting = 0;
2347           nwait += info->waiting;
2348           _ckvmssts(sys$setast(1));
2349           info = info->next;
2350         }
2351         if (!nwait) break;
2352         sleep(1);
2353     }
2354
2355     info = open_pipes;
2356     while (info) {
2357       _ckvmssts(sys$setast(0));
2358       if (!info->done) {  /* We tried to be nice . . . */
2359         sts = sys$delprc(&info->pid,0);
2360         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
2361       }
2362       _ckvmssts(sys$setast(1));
2363       info = info->next;
2364     }
2365
2366     while(open_pipes) {
2367       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2368       else if (!(sts & 1)) retsts = sts;
2369     }
2370     return retsts;
2371 }
2372
2373 static struct exit_control_block pipe_exitblock =
2374        {(struct exit_control_block *) 0,
2375         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2376
2377 static void pipe_mbxtofd_ast(pPipe p);
2378 static void pipe_tochild1_ast(pPipe p);
2379 static void pipe_tochild2_ast(pPipe p);
2380
2381 static void
2382 popen_completion_ast(pInfo info)
2383 {
2384   pInfo i = open_pipes;
2385   int iss;
2386   int sts;
2387   pXpipe x;
2388
2389   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2390   closed_list[closed_index].pid = info->pid;
2391   closed_list[closed_index].completion = info->completion;
2392   closed_index++;
2393   if (closed_index == NKEEPCLOSED)
2394     closed_index = 0;
2395   closed_num++;
2396
2397   while (i) {
2398     if (i == info) break;
2399     i = i->next;
2400   }
2401   if (!i) return;       /* unlinked, probably freed too */
2402
2403   info->done = TRUE;
2404
2405 /*
2406     Writing to subprocess ...
2407             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2408
2409             chan_out may be waiting for "done" flag, or hung waiting
2410             for i/o completion to child...cancel the i/o.  This will
2411             put it into "snarf mode" (done but no EOF yet) that discards
2412             input.
2413
2414     Output from subprocess (stdout, stderr) needs to be flushed and
2415     shut down.   We try sending an EOF, but if the mbx is full the pipe
2416     routine should still catch the "shut_on_empty" flag, telling it to
2417     use immediate-style reads so that "mbx empty" -> EOF.
2418
2419
2420 */
2421   if (info->in && !info->in_done) {               /* only for mode=w */
2422         if (info->in->shut_on_empty && info->in->need_wake) {
2423             info->in->need_wake = FALSE;
2424             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2425         } else {
2426             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2427         }
2428   }
2429
2430   if (info->out && !info->out_done) {             /* were we also piping output? */
2431       info->out->shut_on_empty = TRUE;
2432       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2433       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2434       _ckvmssts_noperl(iss);
2435   }
2436
2437   if (info->err && !info->err_done) {        /* we were piping stderr */
2438         info->err->shut_on_empty = TRUE;
2439         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2440         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2441         _ckvmssts_noperl(iss);
2442   }
2443   _ckvmssts_noperl(sys$setef(pipe_ef));
2444
2445 }
2446
2447 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2448 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2449
2450 /*
2451     we actually differ from vmstrnenv since we use this to
2452     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2453     are pointing to the same thing
2454 */
2455
2456 static unsigned short
2457 popen_translate(pTHX_ char *logical, char *result)
2458 {
2459     int iss;
2460     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2461     $DESCRIPTOR(d_log,"");
2462     struct _il3 {
2463         unsigned short length;
2464         unsigned short code;
2465         char *         buffer_addr;
2466         unsigned short *retlenaddr;
2467     } itmlst[2];
2468     unsigned short l, ifi;
2469
2470     d_log.dsc$a_pointer = logical;
2471     d_log.dsc$w_length  = strlen(logical);
2472
2473     itmlst[0].code = LNM$_STRING;
2474     itmlst[0].length = 255;
2475     itmlst[0].buffer_addr = result;
2476     itmlst[0].retlenaddr = &l;
2477
2478     itmlst[1].code = 0;
2479     itmlst[1].length = 0;
2480     itmlst[1].buffer_addr = 0;
2481     itmlst[1].retlenaddr = 0;
2482
2483     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2484     if (iss == SS$_NOLOGNAM) {
2485         iss = SS$_NORMAL;
2486         l = 0;
2487     }
2488     if (!(iss&1)) lib$signal(iss);
2489     result[l] = '\0';
2490 /*
2491     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
2492     strip it off and return the ifi, if any
2493 */
2494     ifi  = 0;
2495     if (result[0] == 0x1b && result[1] == 0x00) {
2496         memmove(&ifi,result+2,2);
2497         strcpy(result,result+4);
2498     }
2499     return ifi;     /* this is the RMS internal file id */
2500 }
2501
2502 static void pipe_infromchild_ast(pPipe p);
2503
2504 /*
2505     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2506     inside an AST routine without worrying about reentrancy and which Perl
2507     memory allocator is being used.
2508
2509     We read data and queue up the buffers, then spit them out one at a
2510     time to the output mailbox when the output mailbox is ready for one.
2511
2512 */
2513 #define INITIAL_TOCHILDQUEUE  2
2514
2515 static pPipe
2516 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2517 {
2518     pPipe p;
2519     pCBuf b;
2520     char mbx1[64], mbx2[64];
2521     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2522                                       DSC$K_CLASS_S, mbx1},
2523                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2524                                       DSC$K_CLASS_S, mbx2};
2525     unsigned int dviitm = DVI$_DEVBUFSIZ;
2526     int j, n;
2527
2528     Newx(p, 1, Pipe);
2529
2530     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2531     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2532     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2533
2534     p->buf           = 0;
2535     p->shut_on_empty = FALSE;
2536     p->need_wake     = FALSE;
2537     p->type          = 0;
2538     p->retry         = 0;
2539     p->iosb.status   = SS$_NORMAL;
2540     p->iosb2.status  = SS$_NORMAL;
2541     p->free          = RQE_ZERO;
2542     p->wait          = RQE_ZERO;
2543     p->curr          = 0;
2544     p->curr2         = 0;
2545     p->info          = 0;
2546 #ifdef PERL_IMPLICIT_CONTEXT
2547     p->thx           = aTHX;
2548 #endif
2549
2550     n = sizeof(CBuf) + p->bufsize;
2551
2552     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2553         _ckvmssts(lib$get_vm(&n, &b));
2554         b->buf = (char *) b + sizeof(CBuf);
2555         _ckvmssts(lib$insqhi(b, &p->free));
2556     }
2557
2558     pipe_tochild2_ast(p);
2559     pipe_tochild1_ast(p);
2560     strcpy(wmbx, mbx1);
2561     strcpy(rmbx, mbx2);
2562     return p;
2563 }
2564
2565 /*  reads the MBX Perl is writing, and queues */
2566
2567 static void
2568 pipe_tochild1_ast(pPipe p)
2569 {
2570     pCBuf b = p->curr;
2571     int iss = p->iosb.status;
2572     int eof = (iss == SS$_ENDOFFILE);
2573     int sts;
2574 #ifdef PERL_IMPLICIT_CONTEXT
2575     pTHX = p->thx;
2576 #endif
2577
2578     if (p->retry) {
2579         if (eof) {
2580             p->shut_on_empty = TRUE;
2581             b->eof     = TRUE;
2582             _ckvmssts(sys$dassgn(p->chan_in));
2583         } else  {
2584             _ckvmssts(iss);
2585         }
2586
2587         b->eof  = eof;
2588         b->size = p->iosb.count;
2589         _ckvmssts(sts = lib$insqhi(b, &p->wait));
2590         if (p->need_wake) {
2591             p->need_wake = FALSE;
2592             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2593         }
2594     } else {
2595         p->retry = 1;   /* initial call */
2596     }
2597
2598     if (eof) {                  /* flush the free queue, return when done */
2599         int n = sizeof(CBuf) + p->bufsize;
2600         while (1) {
2601             iss = lib$remqti(&p->free, &b);
2602             if (iss == LIB$_QUEWASEMP) return;
2603             _ckvmssts(iss);
2604             _ckvmssts(lib$free_vm(&n, &b));
2605         }
2606     }
2607
2608     iss = lib$remqti(&p->free, &b);
2609     if (iss == LIB$_QUEWASEMP) {
2610         int n = sizeof(CBuf) + p->bufsize;
2611         _ckvmssts(lib$get_vm(&n, &b));
2612         b->buf = (char *) b + sizeof(CBuf);
2613     } else {
2614        _ckvmssts(iss);
2615     }
2616
2617     p->curr = b;
2618     iss = sys$qio(0,p->chan_in,
2619              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2620              &p->iosb,
2621              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2622     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2623     _ckvmssts(iss);
2624 }
2625
2626
2627 /* writes queued buffers to output, waits for each to complete before
2628    doing the next */
2629
2630 static void
2631 pipe_tochild2_ast(pPipe p)
2632 {
2633     pCBuf b = p->curr2;
2634     int iss = p->iosb2.status;
2635     int n = sizeof(CBuf) + p->bufsize;
2636     int done = (p->info && p->info->done) ||
2637               iss == SS$_CANCEL || iss == SS$_ABORT;
2638 #if defined(PERL_IMPLICIT_CONTEXT)
2639     pTHX = p->thx;
2640 #endif
2641
2642     do {
2643         if (p->type) {         /* type=1 has old buffer, dispose */
2644             if (p->shut_on_empty) {
2645                 _ckvmssts(lib$free_vm(&n, &b));
2646             } else {
2647                 _ckvmssts(lib$insqhi(b, &p->free));
2648             }
2649             p->type = 0;
2650         }
2651
2652         iss = lib$remqti(&p->wait, &b);
2653         if (iss == LIB$_QUEWASEMP) {
2654             if (p->shut_on_empty) {
2655                 if (done) {
2656                     _ckvmssts(sys$dassgn(p->chan_out));
2657                     *p->pipe_done = TRUE;
2658                     _ckvmssts(sys$setef(pipe_ef));
2659                 } else {
2660                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2661                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2662                 }
2663                 return;
2664             }
2665             p->need_wake = TRUE;
2666             return;
2667         }
2668         _ckvmssts(iss);
2669         p->type = 1;
2670     } while (done);
2671
2672
2673     p->curr2 = b;
2674     if (b->eof) {
2675         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2676             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2677     } else {
2678         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2679             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2680     }
2681
2682     return;
2683
2684 }
2685
2686
2687 static pPipe
2688 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2689 {
2690     pPipe p;
2691     char mbx1[64], mbx2[64];
2692     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2693                                       DSC$K_CLASS_S, mbx1},
2694                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2695                                       DSC$K_CLASS_S, mbx2};
2696     unsigned int dviitm = DVI$_DEVBUFSIZ;
2697
2698     Newx(p, 1, Pipe);
2699     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2700     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2701
2702     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2703     Newx(p->buf, p->bufsize, char);
2704     p->shut_on_empty = FALSE;
2705     p->info   = 0;
2706     p->type   = 0;
2707     p->iosb.status = SS$_NORMAL;
2708 #if defined(PERL_IMPLICIT_CONTEXT)
2709     p->thx = aTHX;
2710 #endif
2711     pipe_infromchild_ast(p);
2712
2713     strcpy(wmbx, mbx1);
2714     strcpy(rmbx, mbx2);
2715     return p;
2716 }
2717
2718 static void
2719 pipe_infromchild_ast(pPipe p)
2720 {
2721     int iss = p->iosb.status;
2722     int eof = (iss == SS$_ENDOFFILE);
2723     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2724     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2725 #if defined(PERL_IMPLICIT_CONTEXT)
2726     pTHX = p->thx;
2727 #endif
2728
2729     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
2730         _ckvmssts(sys$dassgn(p->chan_out));
2731         p->chan_out = 0;
2732     }
2733
2734     /* read completed:
2735             input shutdown if EOF from self (done or shut_on_empty)
2736             output shutdown if closing flag set (my_pclose)
2737             send data/eof from child or eof from self
2738             otherwise, re-read (snarf of data from child)
2739     */
2740
2741     if (p->type == 1) {
2742         p->type = 0;
2743         if (myeof && p->chan_in) {                  /* input shutdown */
2744             _ckvmssts(sys$dassgn(p->chan_in));
2745             p->chan_in = 0;
2746         }
2747
2748         if (p->chan_out) {
2749             if (myeof || kideof) {      /* pass EOF to parent */
2750                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2751                               pipe_infromchild_ast, p,
2752                               0, 0, 0, 0, 0, 0));
2753                 return;
2754             } else if (eof) {       /* eat EOF --- fall through to read*/
2755
2756             } else {                /* transmit data */
2757                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2758                               pipe_infromchild_ast,p,
2759                               p->buf, p->iosb.count, 0, 0, 0, 0));
2760                 return;
2761             }
2762         }
2763     }
2764
2765     /*  everything shut? flag as done */
2766
2767     if (!p->chan_in && !p->chan_out) {
2768         *p->pipe_done = TRUE;
2769         _ckvmssts(sys$setef(pipe_ef));
2770         return;
2771     }
2772
2773     /* write completed (or read, if snarfing from child)
2774             if still have input active,
2775                queue read...immediate mode if shut_on_empty so we get EOF if empty
2776             otherwise,
2777                check if Perl reading, generate EOFs as needed
2778     */
2779
2780     if (p->type == 0) {
2781         p->type = 1;
2782         if (p->chan_in) {
2783             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2784                           pipe_infromchild_ast,p,
2785                           p->buf, p->bufsize, 0, 0, 0, 0);
2786             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2787             _ckvmssts(iss);
2788         } else {           /* send EOFs for extra reads */
2789             p->iosb.status = SS$_ENDOFFILE;
2790             p->iosb.dvispec = 0;
2791             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2792                       0, 0, 0,
2793                       pipe_infromchild_ast, p, 0, 0, 0, 0));
2794         }
2795     }
2796 }
2797
2798 static pPipe
2799 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2800 {
2801     pPipe p;
2802     char mbx[64];
2803     unsigned long dviitm = DVI$_DEVBUFSIZ;
2804     struct stat s;
2805     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2806                                       DSC$K_CLASS_S, mbx};
2807
2808     /* things like terminals and mbx's don't need this filter */
2809     if (fd && fstat(fd,&s) == 0) {
2810         unsigned long dviitm = DVI$_DEVCHAR, devchar;
2811         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2812                                          DSC$K_CLASS_S, s.st_dev};
2813
2814         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2815         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
2816             strcpy(out, s.st_dev);
2817             return 0;
2818         }
2819     }
2820
2821     Newx(p, 1, Pipe);
2822     p->fd_out = dup(fd);
2823     create_mbx(aTHX_ &p->chan_in, &d_mbx);
2824     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2825     Newx(p->buf, p->bufsize+1, char);
2826     p->shut_on_empty = FALSE;
2827     p->retry = 0;
2828     p->info  = 0;
2829     strcpy(out, mbx);
2830
2831     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2832                   pipe_mbxtofd_ast, p,
2833                   p->buf, p->bufsize, 0, 0, 0, 0));
2834
2835     return p;
2836 }
2837
2838 static void
2839 pipe_mbxtofd_ast(pPipe p)
2840 {
2841     int iss = p->iosb.status;
2842     int done = p->info->done;
2843     int iss2;
2844     int eof = (iss == SS$_ENDOFFILE);
2845     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2846     int err = !(iss&1) && !eof;
2847 #if defined(PERL_IMPLICIT_CONTEXT)
2848     pTHX = p->thx;
2849 #endif
2850
2851     if (done && myeof) {               /* end piping */
2852         close(p->fd_out);
2853         sys$dassgn(p->chan_in);
2854         *p->pipe_done = TRUE;
2855         _ckvmssts(sys$setef(pipe_ef));
2856         return;
2857     }
2858
2859     if (!err && !eof) {             /* good data to send to file */
2860         p->buf[p->iosb.count] = '\n';
2861         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2862         if (iss2 < 0) {
2863             p->retry++;
2864             if (p->retry < MAX_RETRY) {
2865                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2866                 return;
2867             }
2868         }
2869         p->retry = 0;
2870     } else if (err) {
2871         _ckvmssts(iss);
2872     }
2873
2874
2875     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2876           pipe_mbxtofd_ast, p,
2877           p->buf, p->bufsize, 0, 0, 0, 0);
2878     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2879     _ckvmssts(iss);
2880 }
2881
2882
2883 typedef struct _pipeloc     PLOC;
2884 typedef struct _pipeloc*   pPLOC;
2885
2886 struct _pipeloc {
2887     pPLOC   next;
2888     char    dir[NAM$C_MAXRSS+1];
2889 };
2890 static pPLOC  head_PLOC = 0;
2891
2892 void
2893 free_pipelocs(pTHX_ void *head)
2894 {
2895     pPLOC p, pnext;
2896     pPLOC *pHead = (pPLOC *)head;
2897
2898     p = *pHead;
2899     while (p) {
2900         pnext = p->next;
2901         PerlMem_free(p);
2902         p = pnext;
2903     }
2904     *pHead = 0;
2905 }
2906
2907 static void
2908 store_pipelocs(pTHX)
2909 {
2910     int    i;
2911     pPLOC  p;
2912     AV    *av = 0;
2913     SV    *dirsv;
2914     GV    *gv;
2915     char  *dir, *x;
2916     char  *unixdir;
2917     char  temp[NAM$C_MAXRSS+1];
2918     STRLEN n_a;
2919
2920     if (head_PLOC)
2921         free_pipelocs(aTHX_ &head_PLOC);
2922
2923 /*  the . directory from @INC comes last */
2924
2925     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2926     p->next = head_PLOC;
2927     head_PLOC = p;
2928     strcpy(p->dir,"./");
2929
2930 /*  get the directory from $^X */
2931
2932 #ifdef PERL_IMPLICIT_CONTEXT
2933     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2934 #else
2935     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2936 #endif
2937         strcpy(temp, PL_origargv[0]);
2938         x = strrchr(temp,']');
2939         if (x == NULL) {
2940         x = strrchr(temp,'>');
2941           if (x == NULL) {
2942             /* It could be a UNIX path */
2943             x = strrchr(temp,'/');
2944           }
2945         }
2946         if (x)
2947           x[1] = '\0';
2948         else {
2949           /* Got a bare name, so use default directory */
2950           temp[0] = '.';
2951           temp[1] = '\0';
2952         }
2953
2954         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2955             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2956             p->next = head_PLOC;
2957             head_PLOC = p;
2958             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2959             p->dir[NAM$C_MAXRSS] = '\0';
2960         }
2961     }
2962
2963 /*  reverse order of @INC entries, skip "." since entered above */
2964
2965 #ifdef PERL_IMPLICIT_CONTEXT
2966     if (aTHX)
2967 #endif
2968     if (PL_incgv) av = GvAVn(PL_incgv);
2969
2970     for (i = 0; av && i <= AvFILL(av); i++) {
2971         dirsv = *av_fetch(av,i,TRUE);
2972
2973         if (SvROK(dirsv)) continue;
2974         dir = SvPVx(dirsv,n_a);
2975         if (strcmp(dir,".") == 0) continue;
2976         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2977             continue;
2978
2979         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2980         p->next = head_PLOC;
2981         head_PLOC = p;
2982         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2983         p->dir[NAM$C_MAXRSS] = '\0';
2984     }
2985
2986 /* most likely spot (ARCHLIB) put first in the list */
2987
2988 #ifdef ARCHLIB_EXP
2989     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2990         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2991         p->next = head_PLOC;
2992         head_PLOC = p;
2993         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2994         p->dir[NAM$C_MAXRSS] = '\0';
2995     }
2996 #endif
2997 }
2998
2999
3000 static char *
3001 find_vmspipe(pTHX)
3002 {
3003     static int   vmspipe_file_status = 0;
3004     static char  vmspipe_file[NAM$C_MAXRSS+1];
3005
3006     /* already found? Check and use ... need read+execute permission */
3007
3008     if (vmspipe_file_status == 1) {
3009         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3010          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3011             return vmspipe_file;
3012         }
3013         vmspipe_file_status = 0;
3014     }
3015
3016     /* scan through stored @INC, $^X */
3017
3018     if (vmspipe_file_status == 0) {
3019         char file[NAM$C_MAXRSS+1];
3020         pPLOC  p = head_PLOC;
3021
3022         while (p) {
3023             strcpy(file, p->dir);
3024             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3025             file[NAM$C_MAXRSS] = '\0';
3026             p = p->next;
3027
3028             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3029
3030             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3031              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3032                 vmspipe_file_status = 1;
3033                 return vmspipe_file;
3034             }
3035         }
3036         vmspipe_file_status = -1;   /* failed, use tempfiles */
3037     }
3038
3039     return 0;
3040 }
3041
3042 static FILE *
3043 vmspipe_tempfile(pTHX)
3044 {
3045     char file[NAM$C_MAXRSS+1];
3046     FILE *fp;
3047     static int index = 0;
3048     Stat_t s0, s1;
3049     int cmp_result;
3050
3051     /* create a tempfile */
3052
3053     /* we can't go from   W, shr=get to  R, shr=get without
3054        an intermediate vulnerable state, so don't bother trying...
3055
3056        and lib$spawn doesn't shr=put, so have to close the write
3057
3058        So... match up the creation date/time and the FID to
3059        make sure we're dealing with the same file
3060
3061     */
3062
3063     index++;
3064     if (!decc_filename_unix_only) {
3065       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3066       fp = fopen(file,"w");
3067       if (!fp) {
3068         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3069         fp = fopen(file,"w");
3070         if (!fp) {
3071             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3072             fp = fopen(file,"w");
3073         }
3074       }
3075      }
3076      else {
3077       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3078       fp = fopen(file,"w");
3079       if (!fp) {
3080         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3081         fp = fopen(file,"w");
3082         if (!fp) {
3083           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3084           fp = fopen(file,"w");
3085         }
3086       }
3087     }
3088     if (!fp) return 0;  /* we're hosed */
3089
3090     fprintf(fp,"$! 'f$verify(0)'\n");
3091     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3092     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3093     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3094     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3095     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3096     fprintf(fp,"$ perl_del    = \"delete\"\n");
3097     fprintf(fp,"$ pif         = \"if\"\n");
3098     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3099     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3100     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3101     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3102     fprintf(fp,"$!  --- build command line to get max possible length\n");
3103     fprintf(fp,"$c=perl_popen_cmd0\n");
3104     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3105     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3106     fprintf(fp,"$x=perl_popen_cmd3\n");
3107     fprintf(fp,"$c=c+x\n");
3108     fprintf(fp,"$ perl_on\n");
3109     fprintf(fp,"$ 'c'\n");
3110     fprintf(fp,"$ perl_status = $STATUS\n");
3111     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3112     fprintf(fp,"$ perl_exit 'perl_status'\n");
3113     fsync(fileno(fp));
3114
3115     fgetname(fp, file, 1);
3116     fstat(fileno(fp), (struct stat *)&s0);
3117     fclose(fp);
3118
3119     if (decc_filename_unix_only)
3120         do_tounixspec(file, file, 0);
3121     fp = fopen(file,"r","shr=get");
3122     if (!fp) return 0;
3123     fstat(fileno(fp), (struct stat *)&s1);
3124
3125     #if defined(_USE_STD_STAT)
3126       cmp_result = s0.crtl_stat.st_ino != s1.crtl_stat.st_ino;
3127     #else
3128       cmp_result = memcmp(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino, 6);
3129     #endif
3130     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3131         fclose(fp);
3132         return 0;
3133     }
3134
3135     return fp;
3136 }
3137
3138
3139
3140 static PerlIO *
3141 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3142 {
3143     static int handler_set_up = FALSE;
3144     unsigned long int sts, flags = CLI$M_NOWAIT;
3145     /* The use of a GLOBAL table (as was done previously) rendered
3146      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3147      * environment.  Hence we've switched to LOCAL symbol table.
3148      */
3149     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3150     int j, wait = 0;
3151     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3152     char in[512], out[512], err[512], mbx[512];
3153     FILE *tpipe = 0;
3154     char tfilebuf[NAM$C_MAXRSS+1];
3155     pInfo info;
3156     char cmd_sym_name[20];
3157     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3158                                       DSC$K_CLASS_S, symbol};
3159     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3160                                       DSC$K_CLASS_S, 0};
3161     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3162                                       DSC$K_CLASS_S, cmd_sym_name};
3163     struct dsc$descriptor_s *vmscmd;
3164     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3165     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3166     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3167
3168     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3169
3170     /* once-per-program initialization...
3171        note that the SETAST calls and the dual test of pipe_ef
3172        makes sure that only the FIRST thread through here does
3173        the initialization...all other threads wait until it's
3174        done.
3175
3176        Yeah, uglier than a pthread call, it's got all the stuff inline
3177        rather than in a separate routine.
3178     */
3179
3180     if (!pipe_ef) {
3181         _ckvmssts(sys$setast(0));
3182         if (!pipe_ef) {
3183             unsigned long int pidcode = JPI$_PID;
3184             $DESCRIPTOR(d_delay, RETRY_DELAY);
3185             _ckvmssts(lib$get_ef(&pipe_ef));
3186             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3187             _ckvmssts(sys$bintim(&d_delay, delaytime));
3188         }
3189         if (!handler_set_up) {
3190           _ckvmssts(sys$dclexh(&pipe_exitblock));
3191           handler_set_up = TRUE;
3192         }
3193         _ckvmssts(sys$setast(1));
3194     }
3195
3196     /* see if we can find a VMSPIPE.COM */
3197
3198     tfilebuf[0] = '@';
3199     vmspipe = find_vmspipe(aTHX);
3200     if (vmspipe) {
3201         strcpy(tfilebuf+1,vmspipe);
3202     } else {        /* uh, oh...we're in tempfile hell */
3203         tpipe = vmspipe_tempfile(aTHX);
3204         if (!tpipe) {       /* a fish popular in Boston */
3205             if (ckWARN(WARN_PIPE)) {
3206                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3207             }
3208         return Nullfp;
3209         }
3210         fgetname(tpipe,tfilebuf+1,1);
3211     }
3212     vmspipedsc.dsc$a_pointer = tfilebuf;
3213     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3214
3215     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3216     if (!(sts & 1)) {
3217       switch (sts) {
3218         case RMS$_FNF:  case RMS$_DNF:
3219           set_errno(ENOENT); break;
3220         case RMS$_DIR:
3221           set_errno(ENOTDIR); break;
3222         case RMS$_DEV:
3223           set_errno(ENODEV); break;
3224         case RMS$_PRV:
3225           set_errno(EACCES); break;
3226         case RMS$_SYN:
3227           set_errno(EINVAL); break;
3228         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3229           set_errno(E2BIG); break;
3230         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3231           _ckvmssts(sts); /* fall through */
3232         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3233           set_errno(EVMSERR);
3234       }
3235       set_vaxc_errno(sts);
3236       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3237         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3238       }
3239       *psts = sts;
3240       return Nullfp;
3241     }
3242     Newx(info,1,Info);
3243
3244     strcpy(mode,in_mode);
3245     info->mode = *mode;
3246     info->done = FALSE;
3247     info->completion = 0;
3248     info->closing    = FALSE;
3249     info->in         = 0;
3250     info->out        = 0;
3251     info->err        = 0;
3252     info->fp         = Nullfp;
3253     info->useFILE    = 0;
3254     info->waiting    = 0;
3255     info->in_done    = TRUE;
3256     info->out_done   = TRUE;
3257     info->err_done   = TRUE;
3258     in[0] = out[0] = err[0] = '\0';
3259
3260     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3261         info->useFILE = 1;
3262         strcpy(p,p+1);
3263     }
3264     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3265         wait = 1;
3266         strcpy(p,p+1);
3267     }
3268
3269     if (*mode == 'r') {             /* piping from subroutine */
3270
3271         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3272         if (info->out) {
3273             info->out->pipe_done = &info->out_done;
3274             info->out_done = FALSE;
3275             info->out->info = info;
3276         }
3277         if (!info->useFILE) {
3278         info->fp  = PerlIO_open(mbx, mode);
3279         } else {
3280             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3281             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3282         }
3283
3284         if (!info->fp && info->out) {
3285             sys$cancel(info->out->chan_out);
3286
3287             while (!info->out_done) {
3288                 int done;
3289                 _ckvmssts(sys$setast(0));
3290                 done = info->out_done;
3291                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3292                 _ckvmssts(sys$setast(1));
3293                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3294             }
3295
3296             if (info->out->buf) Safefree(info->out->buf);
3297             Safefree(info->out);
3298             Safefree(info);
3299             *psts = RMS$_FNF;
3300             return Nullfp;
3301         }
3302
3303         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3304         if (info->err) {
3305             info->err->pipe_done = &info->err_done;
3306             info->err_done = FALSE;
3307             info->err->info = info;
3308         }
3309
3310     } else if (*mode == 'w') {      /* piping to subroutine */
3311
3312         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3313         if (info->out) {
3314             info->out->pipe_done = &info->out_done;
3315             info->out_done = FALSE;
3316             info->out->info = info;
3317         }
3318
3319         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3320         if (info->err) {
3321             info->err->pipe_done = &info->err_done;
3322             info->err_done = FALSE;
3323             info->err->info = info;
3324         }
3325
3326         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3327         if (!info->useFILE) {
3328         info->fp  = PerlIO_open(mbx, mode);
3329         } else {
3330             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3331             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3332         }
3333
3334         if (info->in) {
3335             info->in->pipe_done = &info->in_done;
3336             info->in_done = FALSE;
3337             info->in->info = info;
3338         }
3339
3340         /* error cleanup */
3341         if (!info->fp && info->in) {
3342             info->done = TRUE;
3343             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3344                               0, 0, 0, 0, 0, 0, 0, 0));
3345
3346             while (!info->in_done) {
3347                 int done;
3348                 _ckvmssts(sys$setast(0));
3349                 done = info->in_done;
3350                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3351                 _ckvmssts(sys$setast(1));
3352                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3353             }
3354
3355             if (info->in->buf) Safefree(info->in->buf);
3356             Safefree(info->in);
3357             Safefree(info);
3358             *psts = RMS$_FNF;
3359             return Nullfp;
3360         }
3361
3362
3363     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3364         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3365         if (info->out) {
3366             info->out->pipe_done = &info->out_done;
3367             info->out_done = FALSE;
3368             info->out->info = info;
3369         }
3370
3371         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3372         if (info->err) {
3373             info->err->pipe_done = &info->err_done;
3374             info->err_done = FALSE;
3375             info->err->info = info;
3376         }
3377     }
3378
3379     symbol[MAX_DCL_SYMBOL] = '\0';
3380
3381     strncpy(symbol, in, MAX_DCL_SYMBOL);
3382     d_symbol.dsc$w_length = strlen(symbol);
3383     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3384
3385     strncpy(symbol, err, MAX_DCL_SYMBOL);
3386     d_symbol.dsc$w_length = strlen(symbol);
3387     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3388
3389     strncpy(symbol, out, MAX_DCL_SYMBOL);
3390     d_symbol.dsc$w_length = strlen(symbol);
3391     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3392
3393     p = vmscmd->dsc$a_pointer;
3394     while (*p && *p != '\n') p++;
3395     *p = '\0';                                  /* truncate on \n */
3396     p = vmscmd->dsc$a_pointer;
3397     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
3398     if (*p == '$') p++;                         /* remove leading $ */
3399     while (*p == ' ' || *p == '\t') p++;
3400
3401     for (j = 0; j < 4; j++) {
3402         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3403         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3404
3405     strncpy(symbol, p, MAX_DCL_SYMBOL);
3406     d_symbol.dsc$w_length = strlen(symbol);
3407     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3408
3409         if (strlen(p) > MAX_DCL_SYMBOL) {
3410             p += MAX_DCL_SYMBOL;
3411         } else {
3412             p += strlen(p);
3413         }
3414     }
3415     _ckvmssts(sys$setast(0));
3416     info->next=open_pipes;  /* prepend to list */
3417     open_pipes=info;
3418     _ckvmssts(sys$setast(1));
3419     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3420      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
3421      * have SYS$COMMAND if we need it.
3422      */
3423     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3424                       0, &info->pid, &info->completion,
3425                       0, popen_completion_ast,info,0,0,0));
3426
3427     /* if we were using a tempfile, close it now */
3428
3429     if (tpipe) fclose(tpipe);
3430
3431     /* once the subprocess is spawned, it has copied the symbols and
3432        we can get rid of ours */
3433
3434     for (j = 0; j < 4; j++) {
3435         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3436         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3437     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3438     }
3439     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
3440     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3441     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3442     vms_execfree(vmscmd);
3443
3444 #ifdef PERL_IMPLICIT_CONTEXT
3445     if (aTHX)
3446 #endif
3447     PL_forkprocess = info->pid;
3448
3449     if (wait) {
3450          int done = 0;
3451          while (!done) {
3452              _ckvmssts(sys$setast(0));
3453              done = info->done;
3454              if (!done) _ckvmssts(sys$clref(pipe_ef));
3455              _ckvmssts(sys$setast(1));
3456              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3457          }
3458         *psts = info->completion;
3459 /* Caller thinks it is open and tries to close it. */
3460 /* This causes some problems, as it changes the error status */
3461 /*        my_pclose(info->fp); */
3462     } else {
3463         *psts = SS$_NORMAL;
3464     }
3465     return info->fp;
3466 }  /* end of safe_popen */
3467
3468
3469 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
3470 PerlIO *
3471 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3472 {
3473     int sts;
3474     TAINT_ENV();
3475     TAINT_PROPER("popen");
3476     PERL_FLUSHALL_FOR_CHILD;
3477     return safe_popen(aTHX_ cmd,mode,&sts);
3478 }
3479
3480 /*}}}*/
3481
3482 /*{{{  I32 my_pclose(PerlIO *fp)*/
3483 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3484 {
3485     pInfo info, last = NULL;
3486     unsigned long int retsts;
3487     int done, iss;
3488
3489     for (info = open_pipes; info != NULL; last = info, info = info->next)
3490         if (info->fp == fp) break;
3491
3492     if (info == NULL) {  /* no such pipe open */
3493       set_errno(ECHILD); /* quoth POSIX */
3494       set_vaxc_errno(SS$_NONEXPR);
3495       return -1;
3496     }
3497
3498     /* If we were writing to a subprocess, insure that someone reading from
3499      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
3500      * produce an EOF record in the mailbox.
3501      *
3502      *  well, at least sometimes it *does*, so we have to watch out for
3503      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
3504      */
3505      if (info->fp) {
3506         if (!info->useFILE)
3507      PerlIO_flush(info->fp);   /* first, flush data */
3508         else
3509             fflush((FILE *)info->fp);
3510     }
3511
3512     _ckvmssts(sys$setast(0));
3513      info->closing = TRUE;
3514      done = info->done && info->in_done && info->out_done && info->err_done;
3515      /* hanging on write to Perl's input? cancel it */
3516      if (info->mode == 'r' && info->out && !info->out_done) {
3517         if (info->out->chan_out) {
3518             _ckvmssts(sys$cancel(info->out->chan_out));
3519             if (!info->out->chan_in) {   /* EOF generation, need AST */
3520                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3521             }
3522         }
3523      }
3524      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
3525          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3526                            0, 0, 0, 0, 0, 0));
3527     _ckvmssts(sys$setast(1));
3528     if (info->fp) {
3529      if (!info->useFILE)
3530     PerlIO_close(info->fp);
3531      else
3532         fclose((FILE *)info->fp);
3533     }
3534      /*
3535         we have to wait until subprocess completes, but ALSO wait until all
3536         the i/o completes...otherwise we'll be freeing the "info" structure
3537         that the i/o ASTs could still be using...
3538      */
3539
3540      while (!done) {
3541          _ckvmssts(sys$setast(0));
3542          done = info->done && info->in_done && info->out_done && info->err_done;
3543          if (!done) _ckvmssts(sys$clref(pipe_ef));
3544          _ckvmssts(sys$setast(1));
3545          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3546      }
3547      retsts = info->completion;
3548
3549     /* remove from list of open pipes */
3550     _ckvmssts(sys$setast(0));
3551     if (last) last->next = info->next;
3552     else open_pipes = info->next;
3553     _ckvmssts(sys$setast(1));
3554
3555     /* free buffers and structures */
3556
3557     if (info->in) {
3558         if (info->in->buf) Safefree(info->in->buf);
3559         Safefree(info->in);
3560     }
3561     if (info->out) {
3562         if (info->out->buf) Safefree(info->out->buf);
3563         Safefree(info->out);
3564     }
3565     if (info->err) {
3566         if (info->err->buf) Safefree(info->err->buf);
3567         Safefree(info->err);
3568     }
3569     Safefree(info);
3570
3571     return retsts;
3572
3573 }  /* end of my_pclose() */
3574
3575 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3576   /* Roll our own prototype because we want this regardless of whether
3577    * _VMS_WAIT is defined.
3578    */
3579   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3580 #endif
3581 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3582    created with popen(); otherwise partially emulate waitpid() unless
3583    we have a suitable one from the CRTL that came with VMS 7.2 and later.
3584    Also check processes not considered by the CRTL waitpid().
3585  */
3586 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3587 Pid_t
3588 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3589 {
3590     pInfo info;
3591     int done;
3592     int sts;
3593     int j;
3594
3595     if (statusp) *statusp = 0;
3596
3597     for (info = open_pipes; info != NULL; info = info->next)
3598         if (info->pid == pid) break;
3599
3600     if (info != NULL) {  /* we know about this child */
3601       while (!info->done) {
3602           _ckvmssts(sys$setast(0));
3603           done = info->done;
3604           if (!done) _ckvmssts(sys$clref(pipe_ef));
3605           _ckvmssts(sys$setast(1));
3606           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3607       }
3608
3609       if (statusp) *statusp = info->completion;
3610       return pid;
3611     }
3612
3613     /* child that already terminated? */
3614
3615     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3616         if (closed_list[j].pid == pid) {
3617             if (statusp) *statusp = closed_list[j].completion;
3618             return pid;
3619         }
3620     }
3621
3622     /* fall through if this child is not one of our own pipe children */
3623
3624 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3625
3626       /* waitpid() became available in the CRTL as of VMS 7.0, but only
3627        * in 7.2 did we get a version that fills in the VMS completion
3628        * status as Perl has always tried to do.
3629        */
3630
3631       sts = __vms_waitpid( pid, statusp, flags );
3632
3633       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3634          return sts;
3635
3636       /* If the real waitpid tells us the child does not exist, we
3637        * fall through here to implement waiting for a child that
3638        * was created by some means other than exec() (say, spawned
3639        * from DCL) or to wait for a process that is not a subprocess
3640        * of the current process.
3641        */
3642
3643 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3644
3645     {
3646       $DESCRIPTOR(intdsc,"0 00:00:01");
3647       unsigned long int ownercode = JPI$_OWNER, ownerpid;
3648       unsigned long int pidcode = JPI$_PID, mypid;
3649       unsigned long int interval[2];
3650       unsigned int jpi_iosb[2];
3651       struct itmlst_3 jpilist[2] = {
3652           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
3653           {                      0,         0,                 0, 0}
3654       };
3655
3656       if (pid <= 0) {
3657         /* Sorry folks, we don't presently implement rooting around for
3658            the first child we can find, and we definitely don't want to
3659            pass a pid of -1 to $getjpi, where it is a wildcard operation.
3660          */
3661         set_errno(ENOTSUP);
3662         return -1;
3663       }
3664
3665       /* Get the owner of the child so I can warn if it's not mine. If the
3666        * process doesn't exist or I don't have the privs to look at it,
3667        * I can go home early.
3668        */
3669       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3670       if (sts & 1) sts = jpi_iosb[0];
3671       if (!(sts & 1)) {
3672         switch (sts) {
3673             case SS$_NONEXPR:
3674                 set_errno(ECHILD);
3675                 break;
3676             case SS$_NOPRIV:
3677                 set_errno(EACCES);
3678                 break;
3679             default:
3680                 _ckvmssts(sts);
3681         }
3682         set_vaxc_errno(sts);
3683         return -1;
3684       }
3685
3686       if (ckWARN(WARN_EXEC)) {
3687         /* remind folks they are asking for non-standard waitpid behavior */
3688         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3689         if (ownerpid != mypid)
3690           Perl_warner(aTHX_ packWARN(WARN_EXEC),
3691                       "waitpid: process %x is not a child of process %x",
3692                       pid,mypid);
3693       }
3694
3695       /* simply check on it once a second until it's not there anymore. */
3696
3697       _ckvmssts(sys$bintim(&intdsc,interval));
3698       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3699             _ckvmssts(sys$schdwk(0,0,interval,0));
3700             _ckvmssts(sys$hiber());
3701       }
3702       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3703
3704       _ckvmssts(sts);
3705       return pid;
3706     }
3707 }  /* end of waitpid() */
3708 /*}}}*/
3709 /*}}}*/
3710 /*}}}*/
3711
3712 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3713 char *
3714 my_gconvert(double val, int ndig, int trail, char *buf)
3715 {
3716   static char __gcvtbuf[DBL_DIG+1];
3717   char *loc;
3718
3719   loc = buf ? buf : __gcvtbuf;
3720
3721 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
3722   if (val < 1) {
3723     sprintf(loc,"%.*g",ndig,val);
3724     return loc;
3725   }
3726 #endif
3727
3728   if (val) {
3729     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3730     return gcvt(val,ndig,loc);
3731   }
3732   else {
3733     loc[0] = '0'; loc[1] = '\0';
3734     return loc;
3735   }
3736
3737 }
3738 /*}}}*/
3739
3740
3741 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3742 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
3743  * to expand file specification.  Allows for a single default file
3744  * specification and a simple mask of options.  If outbuf is non-NULL,
3745  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3746  * the resultant file specification is placed.  If outbuf is NULL, the
3747  * resultant file specification is placed into a static buffer.
3748  * The third argument, if non-NULL, is taken to be a default file
3749  * specification string.  The fourth argument is unused at present.
3750  * rmesexpand() returns the address of the resultant string if
3751  * successful, and NULL on error.
3752  *
3753  * New functionality for previously unused opts value:
3754  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
3755  */
3756 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
3757
3758 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
3759 /* ODS-2 only version */
3760 static char *
3761 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3762 {
3763   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
3764   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
3765   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3766   struct FAB myfab = cc$rms_fab;
3767   struct NAM mynam = cc$rms_nam;
3768   STRLEN speclen;
3769   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3770   int sts;
3771
3772   if (!filespec || !*filespec) {
3773     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3774     return NULL;
3775   }
3776   if (!outbuf) {
3777     if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
3778     else    outbuf = __rmsexpand_retbuf;
3779   }
3780   isunix = is_unix_filespec(filespec);
3781   if (isunix) {
3782     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
3783         if (out)
3784            Safefree(out);
3785         return NULL;
3786     }
3787     filespec = vmsfspec;
3788   }
3789
3790   myfab.fab$l_fna = (char *)filespec;  /* cast ok for read only pointer */
3791   myfab.fab$b_fns = strlen(filespec);
3792   myfab.fab$l_nam = &mynam;
3793
3794   if (defspec && *defspec) {
3795     if (strchr(defspec,'/') != NULL) {
3796       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
3797         if (out)
3798            Safefree(out);
3799         return NULL;
3800       }
3801       defspec = tmpfspec;
3802     }
3803     myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
3804     myfab.fab$b_dns = strlen(defspec);
3805   }
3806
3807   mynam.nam$l_esa = esa;
3808   mynam.nam$b_ess = sizeof esa;
3809   mynam.nam$l_rsa = outbuf;
3810   mynam.nam$b_rss = NAM$C_MAXRSS;
3811
3812 #ifdef NAM$M_NO_SHORT_UPCASE
3813   if (decc_efs_case_preserve)
3814     mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3815 #endif
3816
3817   retsts = sys$parse(&myfab,0,0);
3818   if (!(retsts & 1)) {
3819     mynam.nam$b_nop |= NAM$M_SYNCHK;
3820     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
3821       retsts = sys$parse(&myfab,0,0);
3822       if (retsts & 1) goto expanded;
3823     }
3824     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3825     sts = sys$parse(&myfab,0,0);  /* Free search context */
3826     if (out) Safefree(out);
3827     set_vaxc_errno(retsts);
3828     if      (retsts == RMS$_PRV) set_errno(EACCES);
3829     else if (retsts == RMS$_DEV) set_errno(ENODEV);
3830     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3831     else                         set_errno(EVMSERR);
3832     return NULL;
3833   }
3834   retsts = sys$search(&myfab,0,0);
3835   if (!(retsts & 1) && retsts != RMS$_FNF) {
3836     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3837     myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
3838     if (out) Safefree(out);
3839     set_vaxc_errno(retsts);
3840     if      (retsts == RMS$_PRV) set_errno(EACCES);
3841     else                         set_errno(EVMSERR);
3842     return NULL;
3843   }
3844
3845   /* If the input filespec contained any lowercase characters,
3846    * downcase the result for compatibility with Unix-minded code. */
3847   expanded:
3848   if (!decc_efs_case_preserve) {
3849     for (out = myfab.fab$l_fna; *out; out++)
3850       if (islower(*out)) { haslower = 1; break; }
3851   }
3852   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3853   else                 { out = esa;    speclen = mynam.nam$b_esl; }
3854   /* Trim off null fields added by $PARSE
3855    * If type > 1 char, must have been specified in original or default spec
3856    * (not true for version; $SEARCH may have added version of existing file).
3857    */
3858   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3859   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3860              (mynam.nam$l_ver - mynam.nam$l_type == 1);
3861   if (trimver || trimtype) {
3862     if (defspec && *defspec) {
3863       char defesa[NAM$C_MAXRSS];
3864       struct FAB deffab = cc$rms_fab;
3865       struct NAM defnam = cc$rms_nam;
3866
3867       deffab.fab$l_nam = &defnam;
3868       /* cast below ok for read only pointer */
3869       deffab.fab$l_fna = (char *)defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
3870       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
3871       defnam.nam$b_nop = NAM$M_SYNCHK;
3872 #ifdef NAM$M_NO_SHORT_UPCASE
3873       if (decc_efs_case_preserve)
3874         defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3875 #endif
3876       if (sys$parse(&deffab,0,0) & 1) {
3877         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
3878         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
3879       }
3880     }
3881     if (trimver) {
3882       if (*mynam.nam$l_ver != '\"')
3883         speclen = mynam.nam$l_ver - out;
3884     }
3885     if (trimtype) {
3886       /* If we didn't already trim version, copy down */
3887       if (speclen > mynam.nam$l_ver - out)
3888         memmove(mynam.nam$l_type, mynam.nam$l_ver,
3889                speclen - (mynam.nam$l_ver - out));
3890       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
3891     }
3892   }
3893   /* If we just had a directory spec on input, $PARSE "helpfully"
3894    * adds an empty name and type for us */
3895   if (mynam.nam$l_name == mynam.nam$l_type &&
3896       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
3897       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
3898     speclen = mynam.nam$l_name - out;
3899
3900   /* Posix format specifications must have matching quotes */
3901   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
3902     if ((speclen > 1) && (out[speclen-1] != '\"')) {
3903       out[speclen] = '\"';
3904       speclen++;
3905     }
3906   }
3907
3908   out[speclen] = '\0';
3909   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
3910
3911   /* Have we been working with an expanded, but not resultant, spec? */
3912   /* Also, convert back to Unix syntax if necessary. */
3913   if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
3914     isunix = 0;
3915
3916   if (!mynam.nam$b_rsl) {
3917     if (isunix) {
3918       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
3919     }
3920     else strcpy(outbuf,esa);
3921   }
3922   else if (isunix) {
3923     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
3924     strcpy(outbuf,tmpfspec);
3925   }
3926   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3927   mynam.nam$l_rsa = NULL;
3928   mynam.nam$b_rss = 0;
3929   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);  /* Free search context */
3930   return outbuf;
3931 }
3932 #else
3933 /* ODS-5 supporting routine */
3934 static char *
3935 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3936 {
3937   static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
3938   char * vmsfspec, *tmpfspec;
3939   char * esa, *cp, *out = NULL;
3940   char * esal;
3941   char * outbufl;
3942   struct FAB myfab = cc$rms_fab;
3943   struct NAML mynam = cc$rms_naml;
3944   STRLEN speclen;
3945   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3946   int sts;
3947
3948   if (!filespec || !*filespec) {
3949     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3950     return NULL;
3951   }
3952   if (!outbuf) {
3953     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
3954     else    outbuf = __rmsexpand_retbuf;
3955   }
3956
3957   vmsfspec = NULL;
3958   tmpfspec = NULL;
3959   outbufl = NULL;
3960   isunix = is_unix_filespec(filespec);
3961   if (isunix) {
3962     Newx(vmsfspec, VMS_MAXRSS, char);
3963     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
3964         Safefree(vmsfspec);
3965         if (out)
3966            Safefree(out);
3967         return NULL;
3968     }
3969     filespec = vmsfspec;
3970
3971      /* Unless we are forcing to VMS format, a UNIX input means
3972       * UNIX output, and that requires long names to be used
3973       */
3974     if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
3975         opts |= PERL_RMSEXPAND_M_LONG;
3976     else {
3977         isunix = 0;
3978     }
3979   }
3980
3981   myfab.fab$l_fna = (char *)-1; /* cast ok */
3982   myfab.fab$b_fns = 0;
3983   mynam.naml$l_long_filename = (char *)filespec; /* cast ok */
3984   mynam.naml$l_long_filename_size = strlen(filespec);
3985   myfab.fab$l_naml = &mynam;
3986
3987   if (defspec && *defspec) {
3988     int t_isunix;
3989     t_isunix = is_unix_filespec(defspec);
3990     if (t_isunix) {
3991       Newx(tmpfspec, VMS_MAXRSS, char);
3992       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
3993         Safefree(tmpfspec);
3994         if (vmsfspec != NULL)
3995             Safefree(vmsfspec);
3996         if (out)
3997            Safefree(out);
3998         return NULL;
3999       }
4000       defspec = tmpfspec;
4001     }
4002     myfab.fab$l_dna = (char *) -1; /* cast ok */
4003     myfab.fab$b_dns = 0;
4004     mynam.naml$l_long_defname = (char *)defspec; /* cast ok */
4005     mynam.naml$l_long_defname_size = strlen(defspec);
4006   }
4007
4008   Newx(esa, NAM$C_MAXRSS + 1, char);
4009   Newx(esal, NAML$C_MAXRSS + 1, char);
4010   mynam.naml$l_esa = esa;
4011   mynam.naml$b_ess = NAM$C_MAXRSS;
4012   mynam.naml$l_long_expand = esal;
4013   mynam.naml$l_long_expand_alloc = NAML$C_MAXRSS;
4014
4015   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4016     mynam.naml$l_rsa = NULL;
4017     mynam.naml$b_rss = 0;
4018     mynam.naml$l_long_result = outbuf;
4019     mynam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
4020   }
4021   else {
4022     mynam.naml$l_rsa = outbuf;
4023     mynam.naml$b_rss = NAM$C_MAXRSS;
4024     Newx(outbufl, VMS_MAXRSS, char);
4025     mynam.naml$l_long_result = outbufl;
4026     mynam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
4027   }
4028
4029 #ifdef NAM$M_NO_SHORT_UPCASE
4030   if (decc_efs_case_preserve)
4031     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
4032 #endif
4033
4034   /* First attempt to parse as an existing file */
4035   retsts = sys$parse(&myfab,0,0);
4036   if (!(retsts & STS$K_SUCCESS)) {
4037
4038     /* Could not find the file, try as syntax only if error is not fatal */
4039     mynam.naml$b_nop |= NAM$M_SYNCHK;
4040     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4041       retsts = sys$parse(&myfab,0,0);
4042       if (retsts & STS$K_SUCCESS) goto expanded;
4043     }
4044
4045      /* Still could not parse the file specification */
4046     /*----------------------------------------------*/
4047     mynam.naml$l_rlf = NULL;
4048     myfab.fab$b_dns = 0;
4049     mynam.naml$l_long_defname_size = 0;
4050     sts = sys$parse(&myfab,0,0);  /* Free search context */
4051     if (out) Safefree(out);
4052     if (tmpfspec != NULL)
4053         Safefree(tmpfspec);
4054     if (vmsfspec != NULL)
4055         Safefree(vmsfspec);
4056     Safefree(esa);
4057     Safefree(esal);
4058     set_vaxc_errno(retsts);
4059     if      (retsts == RMS$_PRV) set_errno(EACCES);
4060     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4061     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4062     else                         set_errno(EVMSERR);
4063     return NULL;
4064   }
4065   retsts = sys$search(&myfab,0,0);
4066   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4067     mynam.naml$b_nop |= NAM$M_SYNCHK;
4068     mynam.naml$l_rlf = NULL;
4069     myfab.fab$b_dns = 0;
4070     mynam.naml$l_long_defname_size = 0;
4071     sts = sys$parse(&myfab,0,0);  /* Free search context */
4072     if (out) Safefree(out);
4073     if (tmpfspec != NULL)
4074         Safefree(tmpfspec);
4075     if (vmsfspec != NULL)
4076         Safefree(vmsfspec);
4077     Safefree(esa);
4078     Safefree(esal);
4079     set_vaxc_errno(retsts);
4080     if      (retsts == RMS$_PRV) set_errno(EACCES);
4081     else                         set_errno(EVMSERR);
4082     return NULL;
4083   }
4084
4085   /* If the input filespec contained any lowercase characters,
4086    * downcase the result for compatibility with Unix-minded code. */
4087   expanded:
4088   if (!decc_efs_case_preserve) {
4089     for (out = mynam.naml$l_long_filename; *out; out++)
4090       if (islower(*out)) { haslower = 1; break; }
4091   }
4092
4093    /* Is a long or a short name expected */
4094   /*------------------------------------*/
4095   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4096     if (mynam.naml$l_long_result_size) {
4097         out = outbuf;
4098         speclen = mynam.naml$l_long_result_size;
4099     }
4100     else {
4101         out = esal; /* Not esa */
4102         speclen = mynam.naml$l_long_expand_size;
4103     }
4104   }
4105   else {
4106     if (mynam.naml$b_rsl) {
4107         out = outbuf;
4108         speclen = mynam.naml$b_rsl;
4109     }
4110     else {
4111         out = esa; /* Not esal */
4112         speclen = mynam.naml$b_esl;
4113     }
4114   }
4115   /* Trim off null fields added by $PARSE
4116    * If type > 1 char, must have been specified in original or default spec
4117    * (not true for version; $SEARCH may have added version of existing file).
4118    */
4119   trimver  = !(mynam.naml$l_fnb & NAM$M_EXP_VER);
4120   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4121     trimtype = !(mynam.naml$l_fnb & NAM$M_EXP_TYPE) &&
4122              (mynam.naml$l_long_ver - mynam.naml$l_long_type == 1);
4123   }
4124   else {
4125     trimtype = !(mynam.naml$l_fnb & NAM$M_EXP_TYPE) &&
4126              (mynam.naml$l_ver - mynam.naml$l_type == 1);
4127   }
4128   if (trimver || trimtype) {
4129     if (defspec && *defspec) {
4130       char *defesal = NULL;
4131       Newx(defesal, NAML$C_MAXRSS + 1, char);
4132       if (defesal != NULL) {
4133         struct FAB deffab = cc$rms_fab;
4134         struct NAML defnam = cc$rms_naml;
4135
4136         deffab.fab$l_naml = &defnam;
4137
4138         deffab.fab$l_fna = (char *) - 1; /* Cast ok */
4139         deffab.fab$b_fns = 0;
4140         defnam.naml$l_long_filename = (char *)defspec; /* Cast ok */
4141         defnam.naml$l_long_filename_size = mynam.naml$l_long_defname_size;
4142         defnam.naml$l_esa = NULL;
4143         defnam.naml$b_ess = 0;
4144         defnam.naml$l_long_expand = defesal;
4145         defnam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
4146         defnam.naml$b_nop = NAM$M_SYNCHK;
4147 #ifdef NAM$M_NO_SHORT_UPCASE
4148         if (decc_efs_case_preserve)
4149           defnam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
4150 #endif
4151         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4152           if (trimver) {
4153              trimver  = !(defnam.naml$l_fnb & NAM$M_EXP_VER);
4154           }
4155           if (trimtype) {
4156             trimtype = !(defnam.naml$l_fnb & NAM$M_EXP_TYPE);
4157           }
4158         }
4159         Safefree(defesal);
4160       }
4161     }
4162     if (trimver) {
4163       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4164         if (*mynam.naml$l_long_ver != '\"')
4165           speclen = mynam.naml$l_long_ver - out;
4166       }
4167       else {
4168         if (*mynam.naml$l_ver != '\"')
4169           speclen = mynam.naml$l_ver - out;
4170       }
4171     }
4172     if (trimtype) {
4173       /* If we didn't already trim version, copy down */
4174       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4175         if (speclen > mynam.naml$l_long_ver - out)
4176           memmove
4177            (mynam.naml$l_long_type,
4178             mynam.naml$l_long_ver,
4179             speclen - (mynam.naml$l_long_ver - out));
4180           speclen -= mynam.naml$l_long_ver - mynam.naml$l_long_type;
4181       }
4182       else {
4183         if (speclen > mynam.naml$l_ver - out)
4184           memmove
4185            (mynam.naml$l_type,
4186             mynam.naml$l_ver,
4187             speclen - (mynam.naml$l_ver - out));
4188           speclen -= mynam.naml$l_ver - mynam.naml$l_type;
4189       }
4190     }
4191   }
4192
4193    /* Done with these copies of the input files */
4194   /*-------------------------------------------*/
4195   if (vmsfspec != NULL)
4196         Safefree(vmsfspec);
4197   if (tmpfspec != NULL)
4198         Safefree(tmpfspec);
4199
4200   /* If we just had a directory spec on input, $PARSE "helpfully"
4201    * adds an empty name and type for us */
4202   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4203     if (mynam.naml$l_long_name == mynam.naml$l_long_type &&
4204         mynam.naml$l_long_ver  == mynam.naml$l_long_type + 1 &&
4205         !(mynam.naml$l_fnb & NAM$M_EXP_NAME))
4206       speclen = mynam.naml$l_long_name - out;
4207   }
4208   else {
4209     if (mynam.naml$l_name == mynam.naml$l_type &&
4210         mynam.naml$l_ver  == mynam.naml$l_type + 1 &&
4211         !(mynam.naml$l_fnb & NAM$M_EXP_NAME))
4212       speclen = mynam.naml$l_name - out;
4213   }
4214
4215   /* Posix format specifications must have matching quotes */
4216   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4217     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4218       out[speclen] = '\"';
4219       speclen++;
4220     }
4221   }
4222   out[speclen] = '\0';
4223   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4224
4225   /* Have we been working with an expanded, but not resultant, spec? */
4226   /* Also, convert back to Unix syntax if necessary. */
4227
4228   if (!mynam.naml$l_long_result_size) {
4229     if (isunix) {
4230       if (do_tounixspec(esa,outbuf,0) == NULL) {
4231         Safefree(esal);
4232         Safefree(esa);
4233         return NULL;
4234       }
4235     }
4236     else strcpy(outbuf,esa);
4237   }
4238   else if (isunix) {
4239     Newx(tmpfspec, VMS_MAXRSS, char);
4240     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4241         Safefree(esa);
4242         Safefree(esal);
4243         Safefree(tmpfspec);
4244         return NULL;
4245     }
4246     strcpy(outbuf,tmpfspec);
4247     Safefree(tmpfspec);
4248   }
4249
4250   mynam.naml$b_nop |= NAM$M_SYNCHK;
4251   mynam.naml$l_rlf = NULL;
4252   mynam.naml$l_rsa = NULL;
4253   mynam.naml$b_rss = 0;
4254   mynam.naml$l_long_result = NULL;
4255   mynam.naml$l_long_result_size = 0;
4256   myfab.fab$b_dns = 0;
4257   mynam.naml$l_long_defname_size = 0;
4258   sts = sys$parse(&myfab,0,0);  /* Free search context */
4259   Safefree(esa);
4260   Safefree(esal);
4261   return outbuf;
4262 }
4263 #endif
4264 /*}}}*/
4265 /* External entry points */
4266 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4267 { return do_rmsexpand(spec,buf,0,def,opt); }
4268 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4269 { return do_rmsexpand(spec,buf,1,def,opt); }
4270
4271
4272 /*
4273 ** The following routines are provided to make life easier when
4274 ** converting among VMS-style and Unix-style directory specifications.
4275 ** All will take input specifications in either VMS or Unix syntax. On
4276 ** failure, all return NULL.  If successful, the routines listed below
4277 ** return a pointer to a buffer containing the appropriately
4278 ** reformatted spec (and, therefore, subsequent calls to that routine
4279 ** will clobber the result), while the routines of the same names with
4280 ** a _ts suffix appended will return a pointer to a mallocd string
4281 ** containing the appropriately reformatted spec.
4282 ** In all cases, only explicit syntax is altered; no check is made that
4283 ** the resulting string is valid or that the directory in question
4284 ** actually exists.
4285 **
4286 **   fileify_dirspec() - convert a directory spec into the name of the
4287 **     directory file (i.e. what you can stat() to see if it's a dir).
4288 **     The style (VMS or Unix) of the result is the same as the style
4289 **     of the parameter passed in.
4290 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4291 **     what you prepend to a filename to indicate what directory it's in).
4292 **     The style (VMS or Unix) of the result is the same as the style
4293 **     of the parameter passed in.
4294 **   tounixpath() - convert a directory spec into a Unix-style path.
4295 **   tovmspath() - convert a directory spec into a VMS-style path.
4296 **   tounixspec() - convert any file spec into a Unix-style file spec.
4297 **   tovmsspec() - convert any file spec into a VMS-style spec.
4298 **
4299 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4300 ** Permission is given to distribute this code as part of the Perl
4301 ** standard distribution under the terms of the GNU General Public
4302 ** License or the Perl Artistic License.  Copies of each may be
4303 ** found in the Perl standard distribution.
4304  */
4305
4306 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
4307 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4308 {
4309     static char __fileify_retbuf[NAM$C_MAXRSS+1];
4310     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4311     char *retspec, *cp1, *cp2, *lastdir;
4312     char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
4313     unsigned short int trnlnm_iter_count;
4314     int sts;
4315
4316     if (!dir || !*dir) {
4317       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4318     }
4319     dirlen = strlen(dir);
4320     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4321     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4322       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4323         dir = "/sys$disk";
4324         dirlen = 9;
4325       }
4326       else
4327         dirlen = 1;
4328     }
4329     if (dirlen > NAM$C_MAXRSS) {
4330       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
4331     }
4332     if (!strpbrk(dir+1,"/]>:")  &&
4333         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4334       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4335       trnlnm_iter_count = 0;
4336       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4337         trnlnm_iter_count++;
4338         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4339       }
4340       dirlen = strlen(trndir);
4341     }
4342     else {
4343       strncpy(trndir,dir,dirlen);
4344       trndir[dirlen] = '\0';
4345     }
4346
4347     /* At this point we are done with *dir and use *trndir which is a
4348      * copy that can be modified.  *dir must not be modified.
4349      */
4350
4351     /* If we were handed a rooted logical name or spec, treat it like a
4352      * simple directory, so that
4353      *    $ Define myroot dev:[dir.]
4354      *    ... do_fileify_dirspec("myroot",buf,1) ...
4355      * does something useful.
4356      */
4357     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4358       trndir[--dirlen] = '\0';
4359       trndir[dirlen-1] = ']';
4360     }
4361     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4362       trndir[--dirlen] = '\0';
4363       trndir[dirlen-1] = '>';
4364     }
4365
4366     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4367       /* If we've got an explicit filename, we can just shuffle the string. */
4368       if (*(cp1+1)) hasfilename = 1;
4369       /* Similarly, we can just back up a level if we've got multiple levels
4370          of explicit directories in a VMS spec which ends with directories. */
4371       else {
4372         for (cp2 = cp1; cp2 > trndir; cp2--) {
4373           if (*cp2 == '.') {
4374             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4375               *cp2 = *cp1; *cp1 = '\0';
4376               hasfilename = 1;
4377               break;
4378             }
4379           }
4380           if (*cp2 == '[' || *cp2 == '<') break;
4381         }
4382       }
4383     }
4384
4385     cp1 = strpbrk(trndir,"]:>"); /* Prepare for future change */
4386     if (hasfilename || !cp1) { /* Unix-style path or filename */
4387       if (trndir[0] == '.') {
4388         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0'))
4389           return do_fileify_dirspec("[]",buf,ts);
4390         else if (trndir[1] == '.' &&
4391                  (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0')))
4392           return do_fileify_dirspec("[-]",buf,ts);
4393       }
4394       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4395         dirlen -= 1;                 /* to last element */
4396         lastdir = strrchr(trndir,'/');
4397       }
4398       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4399         /* If we have "/." or "/..", VMSify it and let the VMS code
4400          * below expand it, rather than repeating the code to handle
4401          * relative components of a filespec here */
4402         do {
4403           if (*(cp1+2) == '.') cp1++;
4404           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4405             if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
4406             if (strchr(vmsdir,'/') != NULL) {
4407               /* If do_tovmsspec() returned it, it must have VMS syntax
4408                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
4409                * the time to check this here only so we avoid a recursion
4410                * loop; otherwise, gigo.
4411                */
4412               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
4413             }
4414             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
4415             return do_tounixspec(trndir,buf,ts);
4416           }
4417           cp1++;
4418         } while ((cp1 = strstr(cp1,"/.")) != NULL);
4419         lastdir = strrchr(trndir,'/');
4420       }
4421       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4422         /* Ditto for specs that end in an MFD -- let the VMS code
4423          * figure out whether it's a real device or a rooted logical. */
4424
4425         /* This should not happen any more.  Allowing the fake /000000
4426          * in a UNIX pathname causes all sorts of problems when trying
4427          * to run in UNIX emulation.  So the VMS to UNIX conversions
4428          * now remove the fake /000000 directories.
4429          */
4430
4431         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4432         if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
4433         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
4434         return do_tounixspec(trndir,buf,ts);
4435       }
4436       else {
4437
4438         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4439              !(lastdir = cp1 = strrchr(trndir,']')) &&
4440              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4441         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
4442           int ver; char *cp3;
4443
4444           /* For EFS or ODS-5 look for the last dot */
4445           if (decc_efs_charset) {
4446               cp2 = strrchr(cp1,'.');
4447           }
4448           if (vms_process_case_tolerant) {
4449               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4450                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4451                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4452                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4453                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4454                             (ver || *cp3)))))) {
4455                   set_errno(ENOTDIR);
4456                   set_vaxc_errno(RMS$_DIR);
4457                   return NULL;
4458               }
4459           }
4460           else {
4461               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4462                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4463                   !*(cp2+3) || *(cp2+3) != 'R' ||
4464                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4465                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4466                             (ver || *cp3)))))) {
4467                  set_errno(ENOTDIR);
4468                  set_vaxc_errno(RMS$_DIR);
4469                  return NULL;
4470               }
4471           }
4472           dirlen = cp2 - trndir;
4473         }
4474       }
4475
4476       retlen = dirlen + 6;
4477       if (buf) retspec = buf;
4478       else if (ts) Newx(retspec,retlen+1,char);
4479       else retspec = __fileify_retbuf;
4480       memcpy(retspec,trndir,dirlen);
4481       retspec[dirlen] = '\0';
4482
4483       /* We've picked up everything up to the directory file name.
4484          Now just add the type and version, and we're set. */
4485       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4486         strcat(retspec,".dir;1");
4487       else
4488         strcat(retspec,".DIR;1");
4489       return retspec;
4490     }
4491     else {  /* VMS-style directory spec */
4492       char esa[NAM$C_MAXRSS+1], term, *cp;
4493       unsigned long int sts, cmplen, haslower = 0;
4494       struct FAB dirfab = cc$rms_fab;
4495       struct NAM savnam, dirnam = cc$rms_nam;
4496
4497       dirfab.fab$b_fns = strlen(trndir);
4498       dirfab.fab$l_fna = trndir;
4499       dirfab.fab$l_nam = &dirnam;
4500       dirfab.fab$l_dna = ".DIR;1";
4501       dirfab.fab$b_dns = 6;
4502       dirnam.nam$b_ess = NAM$C_MAXRSS;
4503       dirnam.nam$l_esa = esa;
4504 #ifdef NAM$M_NO_SHORT_UPCASE
4505       if (decc_efs_case_preserve)
4506         dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4507 #endif
4508
4509       for (cp = trndir; *cp; cp++)
4510         if (islower(*cp)) { haslower = 1; break; }
4511       if (!((sts = sys$parse(&dirfab))&1)) {
4512         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4513           dirnam.nam$b_nop |= NAM$M_SYNCHK;
4514           sts = sys$parse(&dirfab) & 1;
4515         }
4516         if (!sts) {
4517           set_errno(EVMSERR);
4518           set_vaxc_errno(dirfab.fab$l_sts);
4519           return NULL;
4520         }
4521       }
4522       else {
4523         savnam = dirnam;
4524         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
4525           /* Yes; fake the fnb bits so we'll check type below */
4526           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
4527         }
4528         else { /* No; just work with potential name */
4529           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4530           else {
4531             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
4532             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4533             dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4534             return NULL;
4535           }
4536         }
4537       }
4538       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4539         cp1 = strchr(esa,']');
4540         if (!cp1) cp1 = strchr(esa,'>');
4541         if (cp1) {  /* Should always be true */
4542           dirnam.nam$b_esl -= cp1 - esa - 1;
4543           memmove(esa,cp1 + 1,dirnam.nam$b_esl);
4544         }
4545       }
4546       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
4547         /* Yep; check version while we're at it, if it's there. */
4548         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
4549         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
4550           /* Something other than .DIR[;1].  Bzzt. */
4551           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4552           dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4553           set_errno(ENOTDIR);
4554           set_vaxc_errno(RMS$_DIR);
4555           return NULL;
4556         }
4557       }
4558       esa[dirnam.nam$b_esl] = '\0';
4559       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
4560         /* They provided at least the name; we added the type, if necessary, */
4561         if (buf) retspec = buf;                            /* in sys$parse() */
4562         else if (ts) Newx(retspec,dirnam.nam$b_esl+1,char);
4563         else retspec = __fileify_retbuf;
4564         strcpy(retspec,esa);
4565         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4566         dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4567         return retspec;
4568       }
4569       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4570         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4571         *cp1 = '\0';
4572         dirnam.nam$b_esl -= 9;
4573       }
4574       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4575       if (cp1 == NULL) { /* should never happen */
4576         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4577         dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4578         return NULL;
4579       }
4580       term = *cp1;
4581       *cp1 = '\0';
4582       retlen = strlen(esa);
4583       cp1 = strrchr(esa,'.');
4584       /* ODS-5 directory specifications can have extra "." in them. */
4585       while (cp1 != NULL) {
4586         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4587           break;
4588         else {
4589            cp1--;
4590            while ((cp1 > esa) && (*cp1 != '.'))
4591              cp1--;
4592         }
4593         if (cp1 == esa)
4594           cp1 = NULL;
4595       }
4596
4597       if ((cp1) != NULL) {
4598         /* There's more than one directory in the path.  Just roll back. */
4599         *cp1 = term;
4600         if (buf) retspec = buf;
4601         else if (ts) Newx(retspec,retlen+7,char);
4602         else retspec = __fileify_retbuf;
4603         strcpy(retspec,esa);
4604       }
4605       else {
4606         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
4607           /* Go back and expand rooted logical name */
4608           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
4609 #ifdef NAM$M_NO_SHORT_UPCASE
4610           if (decc_efs_case_preserve)
4611             dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4612 #endif
4613           if (!(sys$parse(&dirfab) & 1)) {
4614             dirnam.nam$l_rlf = NULL;
4615             dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4616             set_errno(EVMSERR);
4617             set_vaxc_errno(dirfab.fab$l_sts);
4618             return NULL;
4619           }
4620           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
4621           if (buf) retspec = buf;
4622           else if (ts) Newx(retspec,retlen+16,char);
4623           else retspec = __fileify_retbuf;
4624           cp1 = strstr(esa,"][");
4625           if (!cp1) cp1 = strstr(esa,"]<");
4626           dirlen = cp1 - esa;
4627           memcpy(retspec,esa,dirlen);
4628           if (!strncmp(cp1+2,"000000]",7)) {
4629             retspec[dirlen-1] = '\0';
4630             /* Not full ODS-5, just extra dots in directories for now */
4631             cp1 = retspec + dirlen - 1;
4632             while (cp1 > retspec)
4633             {
4634               if (*cp1 == '[')
4635                 break;
4636               if (*cp1 == '.') {
4637                 if (*(cp1-1) != '^')
4638                   break;
4639               }
4640               cp1--;
4641             }
4642             if (*cp1 == '.') *cp1 = ']';
4643             else {
4644               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4645               memmove(cp1+1,"000000]",7);
4646             }
4647           }
4648           else {
4649             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
4650             retspec[retlen] = '\0';
4651             /* Convert last '.' to ']' */
4652             cp1 = retspec+retlen-1;
4653             while (*cp != '[') {
4654               cp1--;
4655               if (*cp1 == '.') {
4656                 /* Do not trip on extra dots in ODS-5 directories */
4657                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
4658                 break;
4659               }
4660             }
4661             if (*cp1 == '.') *cp1 = ']';
4662             else {
4663               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4664               memmove(cp1+1,"000000]",7);
4665             }
4666           }
4667         }
4668         else {  /* This is a top-level dir.  Add the MFD to the path. */
4669           if (buf) retspec = buf;
4670           else if (ts) Newx(retspec,retlen+16,char);
4671           else retspec = __fileify_retbuf;
4672           cp1 = esa;
4673           cp2 = retspec;
4674           while (*cp1 != ':') *(cp2++) = *(cp1++);
4675           strcpy(cp2,":[000000]");
4676           cp1 += 2;
4677           strcpy(cp2+9,cp1);
4678         }
4679       }
4680       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4681       dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4682       /* We've set up the string up through the filename.  Add the
4683          type and version, and we're done. */
4684       strcat(retspec,".DIR;1");
4685
4686       /* $PARSE may have upcased filespec, so convert output to lower
4687        * case if input contained any lowercase characters. */
4688       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
4689       return retspec;
4690     }
4691 }  /* end of do_fileify_dirspec() */
4692 /*}}}*/
4693 /* External entry points */
4694 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
4695 { return do_fileify_dirspec(dir,buf,0); }
4696 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
4697 { return do_fileify_dirspec(dir,buf,1); }
4698
4699 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
4700 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
4701 {
4702     static char __pathify_retbuf[NAM$C_MAXRSS+1];
4703     unsigned long int retlen;
4704     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
4705     unsigned short int trnlnm_iter_count;
4706     STRLEN trnlen;
4707     int sts;
4708
4709     if (!dir || !*dir) {
4710       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4711     }
4712
4713     if (*dir) strcpy(trndir,dir);
4714     else getcwd(trndir,sizeof trndir - 1);
4715
4716     trnlnm_iter_count = 0;
4717     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
4718            && my_trnlnm(trndir,trndir,0)) {
4719       trnlnm_iter_count++;
4720       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4721       trnlen = strlen(trndir);
4722
4723       /* Trap simple rooted lnms, and return lnm:[000000] */
4724       if (!strcmp(trndir+trnlen-2,".]")) {
4725         if (buf) retpath = buf;
4726         else if (ts) Newx(retpath,strlen(dir)+10,char);
4727         else retpath = __pathify_retbuf;
4728         strcpy(retpath,dir);
4729         strcat(retpath,":[000000]");
4730         return retpath;
4731       }
4732     }
4733
4734     /* At this point we do not work with *dir, but the copy in
4735      * *trndir that is modifiable.
4736      */
4737
4738     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
4739       if (*trndir == '.' && (*(trndir+1) == '\0' ||
4740                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
4741         retlen = 2 + (*(trndir+1) != '\0');
4742       else {
4743         if ( !(cp1 = strrchr(trndir,'/')) &&
4744              !(cp1 = strrchr(trndir,']')) &&
4745              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
4746         if ((cp2 = strchr(cp1,'.')) != NULL &&
4747             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
4748              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
4749               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
4750               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
4751           int ver; char *cp3;
4752
4753           /* For EFS or ODS-5 look for the last dot */
4754           if (decc_efs_charset) {
4755             cp2 = strrchr(cp1,'.');
4756           }
4757           if (vms_process_case_tolerant) {
4758               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4759                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4760                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4761                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4762                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4763                             (ver || *cp3)))))) {
4764                 set_errno(ENOTDIR);
4765                 set_vaxc_errno(RMS$_DIR);
4766                 return NULL;
4767               }
4768           }
4769           else {
4770               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4771                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4772                   !*(cp2+3) || *(cp2+3) != 'R' ||
4773                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4774                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4775                             (ver || *cp3)))))) {
4776                 set_errno(ENOTDIR);
4777                 set_vaxc_errno(RMS$_DIR);
4778                 return NULL;
4779               }
4780           }
4781           retlen = cp2 - trndir + 1;
4782         }
4783         else {  /* No file type present.  Treat the filename as a directory. */
4784           retlen = strlen(trndir) + 1;
4785         }
4786       }
4787       if (buf) retpath = buf;
4788       else if (ts) Newx(retpath,retlen+1,char);
4789       else retpath = __pathify_retbuf;
4790       strncpy(retpath, trndir, retlen-1);
4791       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
4792         retpath[retlen-1] = '/';      /* with '/', add it. */
4793         retpath[retlen] = '\0';
4794       }
4795       else retpath[retlen-1] = '\0';
4796     }
4797     else {  /* VMS-style directory spec */
4798       char esa[NAM$C_MAXRSS+1], *cp;
4799       unsigned long int sts, cmplen, haslower;
4800       struct FAB dirfab = cc$rms_fab;
4801       struct NAM savnam, dirnam = cc$rms_nam;
4802
4803       /* If we've got an explicit filename, we can just shuffle the string. */
4804       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
4805              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
4806         if ((cp2 = strchr(cp1,'.')) != NULL) {
4807           int ver; char *cp3;
4808           if (vms_process_case_tolerant) {
4809               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4810                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4811                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4812                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4813                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4814                             (ver || *cp3)))))) {
4815                set_errno(ENOTDIR);
4816                set_vaxc_errno(RMS$_DIR);
4817                return NULL;
4818              }
4819           }
4820           else {
4821               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4822                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4823                   !*(cp2+3) || *(cp2+3) != 'R' ||
4824                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4825                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4826                             (ver || *cp3)))))) {
4827                set_errno(ENOTDIR);
4828                set_vaxc_errno(RMS$_DIR);
4829                return NULL;
4830              }
4831           }
4832         }
4833         else {  /* No file type, so just draw name into directory part */
4834           for (cp2 = cp1; *cp2; cp2++) ;
4835         }
4836         *cp2 = *cp1;
4837         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
4838         *cp1 = '.';
4839         /* We've now got a VMS 'path'; fall through */
4840       }
4841       dirfab.fab$b_fns = strlen(trndir);
4842       dirfab.fab$l_fna = trndir;
4843       if (trndir[dirfab.fab$b_fns-1] == ']' ||
4844           trndir[dirfab.fab$b_fns-1] == '>' ||
4845           trndir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
4846         if (buf) retpath = buf;
4847         else if (ts) Newx(retpath,strlen(trndir)+1,char);
4848         else retpath = __pathify_retbuf;
4849         strcpy(retpath,trndir);
4850         return retpath;
4851       }
4852       dirfab.fab$l_dna = ".DIR;1";
4853       dirfab.fab$b_dns = 6;
4854       dirfab.fab$l_nam = &dirnam;
4855       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
4856       dirnam.nam$l_esa = esa;
4857 #ifdef NAM$M_NO_SHORT_UPCASE
4858       if (decc_efs_case_preserve)
4859           dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4860 #endif
4861
4862       for (cp = trndir; *cp; cp++)
4863         if (islower(*cp)) { haslower = 1; break; }
4864
4865       if (!(sts = (sys$parse(&dirfab)&1))) {
4866         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4867           dirnam.nam$b_nop |= NAM$M_SYNCHK;
4868           sts = sys$parse(&dirfab) & 1;
4869         }
4870         if (!sts) {
4871           set_errno(EVMSERR);
4872           set_vaxc_errno(dirfab.fab$l_sts);
4873           return NULL;
4874         }
4875       }
4876       else {
4877         savnam = dirnam;
4878         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
4879           if (dirfab.fab$l_sts != RMS$_FNF) {
4880             int sts1;
4881             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4882             dirfab.fab$b_dns = 0;
4883             sts1 = sys$parse(&dirfab,0,0);
4884             set_errno(EVMSERR);
4885             set_vaxc_errno(dirfab.fab$l_sts);
4886             return NULL;
4887           }
4888           dirnam = savnam; /* No; just work with potential name */
4889         }
4890       }
4891       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
4892         /* Yep; check version while we're at it, if it's there. */
4893         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
4894         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
4895           int sts2;
4896           /* Something other than .DIR[;1].  Bzzt. */
4897           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4898           dirfab.fab$b_dns = 0;
4899           sts2 = sys$parse(&dirfab,0,0);
4900           set_errno(ENOTDIR);
4901           set_vaxc_errno(RMS$_DIR);
4902           return NULL;
4903         }
4904       }
4905       /* OK, the type was fine.  Now pull any file name into the
4906          directory path. */
4907       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
4908       else {
4909         cp1 = strrchr(esa,'>');
4910         *dirnam.nam$l_type = '>';
4911       }
4912       *cp1 = '.';
4913       *(dirnam.nam$l_type + 1) = '\0';
4914       retlen = dirnam.nam$l_type - esa + 2;
4915       if (buf) retpath = buf;
4916       else if (ts) Newx(retpath,retlen,char);
4917       else retpath = __pathify_retbuf;
4918       strcpy(retpath,esa);
4919       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4920       dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4921       /* $PARSE may have upcased filespec, so convert output to lower
4922        * case if input contained any lowercase characters. */
4923       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
4924     }
4925
4926     return retpath;
4927 }  /* end of do_pathify_dirspec() */
4928 /*}}}*/
4929 /* External entry points */
4930 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
4931 { return do_pathify_dirspec(dir,buf,0); }
4932 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
4933 { return do_pathify_dirspec(dir,buf,1); }
4934
4935 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
4936 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
4937 {
4938   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
4939   char *dirend, *rslt, *cp1, *cp3, tmp[NAM$C_MAXRSS+1];
4940   const char *cp2;
4941   int devlen, dirlen, retlen = NAM$C_MAXRSS+1;
4942   int expand = 1; /* guarantee room for leading and trailing slashes */
4943   unsigned short int trnlnm_iter_count;
4944   int cmp_rslt;
4945
4946   if (spec == NULL) return NULL;
4947   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
4948   if (buf) rslt = buf;
4949   else if (ts) {
4950     retlen = strlen(spec);
4951     cp1 = strchr(spec,'[');
4952     if (!cp1) cp1 = strchr(spec,'<');
4953     if (cp1) {
4954       for (cp1++; *cp1; cp1++) {
4955         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
4956         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
4957           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
4958       }
4959     }
4960     Newx(rslt,retlen+2+2*expand,char);
4961   }
4962   else rslt = __tounixspec_retbuf;
4963
4964   /* New VMS specific format needs translation
4965    * glob passes filenames with trailing '\n' and expects this preserved.
4966    */
4967   if (decc_posix_compliant_pathnames) {
4968     if (strncmp(spec, "\"^UP^", 5) == 0) {
4969       char * uspec;
4970       char *tunix;
4971       int tunix_len;
4972       int nl_flag;
4973
4974       Newx(tunix, VMS_MAXRSS + 1,char);
4975       strcpy(tunix, spec);
4976       tunix_len = strlen(tunix);
4977       nl_flag = 0;
4978       if (tunix[tunix_len - 1] == '\n') {
4979         tunix[tunix_len - 1] = '\"';
4980         tunix[tunix_len] = '\0';
4981         tunix_len--;
4982         nl_flag = 1;
4983       }
4984       uspec = decc$translate_vms(tunix);
4985       Safefree(tunix);
4986       if ((int)uspec > 0) {
4987         strcpy(rslt,uspec);
4988         if (nl_flag) {
4989           strcat(rslt,"\n");
4990         }
4991         else {
4992           /* If we can not translate it, makemaker wants as-is */
4993           strcpy(rslt, spec);
4994         }
4995         return rslt;
4996       }
4997     }
4998   }
4999
5000   cmp_rslt = 0; /* Presume VMS */
5001   cp1 = strchr(spec, '/');
5002   if (cp1 == NULL)
5003     cmp_rslt = 0;
5004
5005     /* Look for EFS ^/ */
5006     if (decc_efs_charset) {
5007       while (cp1 != NULL) {
5008         cp2 = cp1 - 1;
5009         if (*cp2 != '^') {
5010           /* Found illegal VMS, assume UNIX */
5011           cmp_rslt = 1;
5012           break;
5013         }
5014       cp1++;
5015       cp1 = strchr(cp1, '/');
5016     }
5017   }
5018
5019   /* Look for "." and ".." */
5020   if (decc_filename_unix_report) {
5021     if (spec[0] == '.') {
5022       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5023         cmp_rslt = 1;
5024       }
5025       else {
5026         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5027           cmp_rslt = 1;
5028         }
5029       }
5030     }
5031   }
5032   /* This is already UNIX or at least nothing VMS understands */
5033   if (cmp_rslt) {
5034     strcpy(rslt,spec);
5035     return rslt;
5036   }
5037
5038   cp1 = rslt;
5039   cp2 = spec;
5040   dirend = strrchr(spec,']');
5041   if (dirend == NULL) dirend = strrchr(spec,'>');
5042   if (dirend == NULL) dirend = strchr(spec,':');
5043   if (dirend == NULL) {
5044     strcpy(rslt,spec);
5045     return rslt;
5046   }
5047
5048   /* Special case 1 - sys$posix_root = / */
5049 #if __CRTL_VER >= 70000000
5050   if (!decc_disable_posix_root) {
5051     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5052       *cp1 = '/';
5053       cp1++;
5054       cp2 = cp2 + 15;
5055       }
5056   }
5057 #endif
5058
5059   /* Special case 2 - Convert NLA0: to /dev/null */
5060 #if __CRTL_VER < 70000000
5061   cmp_rslt = strncmp(spec,"NLA0:", 5);
5062   if (cmp_rslt != 0)
5063      cmp_rslt = strncmp(spec,"nla0:", 5);
5064 #else
5065   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5066 #endif
5067   if (cmp_rslt == 0) {
5068     strcpy(rslt, "/dev/null");
5069     cp1 = cp1 + 9;
5070     cp2 = cp2 + 5;
5071     if (spec[6] != '\0') {
5072       cp1[9] == '/';
5073       cp1++;
5074       cp2++;
5075     }
5076   }
5077
5078    /* Also handle special case "SYS$SCRATCH:" */
5079 #if __CRTL_VER < 70000000
5080   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5081   if (cmp_rslt != 0)
5082      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5083 #else
5084   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5085 #endif
5086   if (cmp_rslt == 0) {
5087   int islnm;
5088
5089     islnm = my_trnlnm(tmp, "TMP", 0);
5090     if (!islnm) {
5091       strcpy(rslt, "/tmp");
5092       cp1 = cp1 + 4;
5093       cp2 = cp2 + 12;
5094       if (spec[12] != '\0') {
5095         cp1[4] == '/';
5096         cp1++;
5097         cp2++;
5098       }
5099     }
5100   }
5101
5102   if (*cp2 != '[' && *cp2 != '<') {
5103     *(cp1++) = '/';
5104   }
5105   else {  /* the VMS spec begins with directories */
5106     cp2++;
5107     if (*cp2 == ']' || *cp2 == '>') {
5108       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5109       return rslt;
5110     }
5111     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5112       if (getcwd(tmp,sizeof tmp,1) == NULL) {
5113         if (ts) Safefree(rslt);
5114         return NULL;
5115       }
5116       trnlnm_iter_count = 0;
5117       do {
5118         cp3 = tmp;
5119         while (*cp3 != ':' && *cp3) cp3++;
5120         *(cp3++) = '\0';
5121         if (strchr(cp3,']') != NULL) break;
5122         trnlnm_iter_count++;
5123         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5124       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5125       if (ts && !buf &&
5126           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5127         retlen = devlen + dirlen;
5128         Renew(rslt,retlen+1+2*expand,char);
5129         cp1 = rslt;
5130       }
5131       cp3 = tmp;
5132       *(cp1++) = '/';
5133       while (*cp3) {
5134         *(cp1++) = *(cp3++);
5135         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
5136       }
5137       *(cp1++) = '/';
5138     }
5139     if ((*cp2 == '^')) {
5140         /* EFS file escape, pass the next character as is */
5141         /* Fix me: HEX encoding for UNICODE not implemented */
5142         cp2++;
5143     }
5144     else if ( *cp2 == '.') {
5145       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5146         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5147         cp2 += 3;
5148       }
5149       else cp2++;
5150     }
5151   }
5152   for (; cp2 <= dirend; cp2++) {
5153     if ((*cp2 == '^')) {
5154         /* EFS file escape, pass the next character as is */
5155         /* Fix me: HEX encoding for UNICODE not implemented */
5156         cp2++;
5157         *(cp1++) = *cp2;
5158     }
5159     if (*cp2 == ':') {
5160       *(cp1++) = '/';
5161       if (*(cp2+1) == '[') cp2++;
5162     }
5163     else if (*cp2 == ']' || *cp2 == '>') {
5164       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5165     }
5166     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5167       *(cp1++) = '/';
5168       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5169         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5170                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5171         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5172             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5173       }
5174       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5175         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5176         cp2 += 2;
5177       }
5178     }
5179     else if (*cp2 == '-') {
5180       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5181         while (*cp2 == '-') {
5182           cp2++;
5183           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5184         }
5185         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5186           if (ts) Safefree(rslt);                        /* filespecs like */
5187           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5188           return NULL;
5189         }
5190       }
5191       else *(cp1++) = *cp2;
5192     }
5193     else *(cp1++) = *cp2;
5194   }
5195   while (*cp2) *(cp1++) = *(cp2++);
5196   *cp1 = '\0';
5197
5198   /* This still leaves /000000/ when working with a
5199    * VMS device root or concealed root.
5200    */
5201   {
5202   int ulen;
5203   char * zeros;
5204
5205       ulen = strlen(rslt);
5206
5207       /* Get rid of "000000/ in rooted filespecs */
5208       if (ulen > 7) {
5209         zeros = strstr(rslt, "/000000/");
5210         if (zeros != NULL) {
5211           int mlen;
5212           mlen = ulen - (zeros - rslt) - 7;
5213           memmove(zeros, &zeros[7], mlen);
5214           ulen = ulen - 7;
5215           rslt[ulen] = '\0';
5216         }
5217       }
5218   }
5219
5220   return rslt;
5221
5222 }  /* end of do_tounixspec() */
5223 /*}}}*/
5224 /* External entry points */
5225 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5226 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5227
5228 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5229
5230 static int posix_to_vmsspec
5231   (char *vmspath, int vmspath_len, const char *unixpath) {
5232 int sts;
5233 struct FAB myfab = cc$rms_fab;
5234 struct NAML mynam = cc$rms_naml;
5235 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5236  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5237 char *esa;
5238 char *vms_delim;
5239 int dir_flag;
5240 int unixlen;
5241
5242   /* If not a posix spec already, convert it */
5243   dir_flag = 0;
5244   unixlen = strlen(unixpath);
5245   if (unixlen == 0) {
5246     vmspath[0] = '\0';
5247     return SS$_NORMAL;
5248   }
5249   if (strncmp(unixpath,"\"^UP^",5) != 0) {
5250     sprintf(vmspath,"\"^UP^%s\"",unixpath);
5251   }
5252   else {
5253     /* This is already a VMS specification, no conversion */
5254     unixlen--;
5255     strncpy(vmspath,unixpath, vmspath_len);
5256   }
5257   vmspath[vmspath_len] = 0;
5258   if (unixpath[unixlen - 1] == '/')
5259   dir_flag = 1;
5260   Newx(esa, VMS_MAXRSS+1, char);
5261   myfab.fab$l_fna = vmspath;
5262   myfab.fab$b_fns = strlen(vmspath);
5263   myfab.fab$l_naml = &mynam;
5264   mynam.naml$l_esa = NULL;
5265   mynam.naml$b_ess = 0;
5266   mynam.naml$l_long_expand = esa;
5267   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS;
5268   mynam.naml$l_rsa = NULL;
5269   mynam.naml$b_rss = 0;
5270   if (decc_efs_case_preserve)
5271     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5272   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5273
5274   /* Set up the remaining naml fields */
5275   sts = sys$parse(&myfab);
5276
5277   /* It failed! Try again as a UNIX filespec */
5278   if (!(sts & 1)) {
5279     Safefree(esa);
5280     return sts;
5281   }
5282
5283    /* get the Device ID and the FID */
5284    sts = sys$search(&myfab);
5285    /* on any failure, returned the POSIX ^UP^ filespec */
5286    if (!(sts & 1)) {
5287       Safefree(esa);
5288       return sts;
5289    }
5290    specdsc.dsc$a_pointer = vmspath;
5291    specdsc.dsc$w_length = vmspath_len;
5292
5293    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5294    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5295    sts = lib$fid_to_name
5296       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5297
5298   /* on any failure, returned the POSIX ^UP^ filespec */
5299   if (!(sts & 1)) {
5300      /* This can happen if user does not have permission to read directories */
5301      if (strncmp(unixpath,"\"^UP^",5) != 0)
5302        sprintf(vmspath,"\"^UP^%s\"",unixpath);
5303      else
5304        strcpy(vmspath, unixpath);
5305   }
5306   else {
5307     vmspath[specdsc.dsc$w_length] = 0;
5308
5309     /* Are we expecting a directory? */
5310     if (dir_flag != 0) {
5311     int i;
5312     char *eptr;
5313
5314       eptr = NULL;
5315
5316       i = specdsc.dsc$w_length - 1;
5317       while (i > 0) {
5318       int zercnt;
5319         zercnt = 0;
5320         /* Version must be '1' */
5321         if (vmspath[i--] != '1')
5322           break;
5323         /* Version delimiter is one of ".;" */
5324         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5325           break;
5326         i--;
5327         if (vmspath[i--] != 'R')
5328           break;
5329         if (vmspath[i--] != 'I')
5330           break;
5331         if (vmspath[i--] != 'D')
5332           break;
5333         if (vmspath[i--] != '.')
5334           break;
5335         eptr = &vmspath[i+1];
5336         while (i > 0) {
5337           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5338             if (vmspath[i-1] != '^') {
5339               if (zercnt != 6) {
5340                 *eptr = vmspath[i];
5341                 eptr[1] = '\0';
5342                 vmspath[i] = '.';
5343                 break;
5344               }
5345               else {
5346                 /* Get rid of 6 imaginary zero directory filename */
5347                 vmspath[i+1] = '\0';
5348               }
5349             }
5350           }
5351           if (vmspath[i] == '0')
5352             zercnt++;
5353           else
5354             zercnt = 10;
5355           i--;
5356         }
5357         break;
5358       }
5359     }
5360   }
5361   Safefree(esa);
5362   return sts;
5363 }
5364
5365 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5366 static int posix_to_vmsspec_hardway
5367   (char *vmspath, int vmspath_len, const char *unixpath) {
5368
5369 char *esa;
5370 const char *unixptr;
5371 char *vmsptr;
5372 const char *lastslash;
5373 const char *lastdot;
5374 int unixlen;
5375 int vmslen;
5376 int dir_start;
5377 int dir_dot;
5378 int quoted;
5379
5380
5381   unixptr = unixpath;
5382   dir_dot = 0;
5383
5384   /* Ignore leading "/" characters */
5385   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5386     unixptr++;
5387   }
5388   unixlen = strlen(unixptr);
5389
5390   /* Do nothing with blank paths */
5391   if (unixlen == 0) {
5392     vmspath[0] = '\0';
5393     return SS$_NORMAL;
5394   }
5395
5396   lastslash = strrchr(unixptr,'/');
5397   lastdot = strrchr(unixptr,'.');
5398
5399
5400   /* last dot is last dot or past end of string */
5401   if (lastdot == NULL)
5402     lastdot = unixptr + unixlen;
5403
5404   /* if no directories, set last slash to beginning of string */
5405   if (lastslash == NULL) {
5406     lastslash = unixptr;
5407   }
5408   else {
5409     /* Watch out for trailing "." after last slash, still a directory */
5410     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5411       lastslash = unixptr + unixlen;
5412     }
5413
5414     /* Watch out for traiing ".." after last slash, still a directory */
5415     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5416       lastslash = unixptr + unixlen;
5417     }
5418
5419     /* dots in directories are aways escaped */
5420     if (lastdot < lastslash)
5421       lastdot = unixptr + unixlen;
5422   }
5423
5424   /* if (unixptr < lastslash) then we are in a directory */
5425
5426   dir_start = 0;
5427   quoted = 0;
5428
5429   vmsptr = vmspath;
5430   vmslen = 0;
5431
5432   /* This could have a "^UP^ on the front */
5433   if (strncmp(unixptr,"\"^UP^",5) == 0) {
5434     quoted = 1;
5435     unixptr+= 5;
5436   }
5437
5438   /* Start with the UNIX path */
5439   if (*unixptr != '/') {
5440     /* relative paths */
5441     if (lastslash > unixptr) {
5442     int dotdir_seen;
5443
5444       /* skip leading ./ */
5445       dotdir_seen = 0;
5446       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5447         dotdir_seen = 1;
5448         unixptr++;
5449         unixptr++;
5450       }
5451
5452       /* Are we still in a directory? */
5453       if (unixptr <= lastslash) {
5454         *vmsptr++ = '[';
5455         vmslen = 1;
5456         dir_start = 1;
5457
5458         /* if not backing up, then it is relative forward. */
5459         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5460               ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5461           *vmsptr++ = '.';
5462           vmslen++;
5463           dir_dot = 1;
5464         }
5465        }
5466        else {
5467          if (dotdir_seen) {
5468            /* Perl wants an empty directory here to tell the difference
5469             * between a DCL commmand and a filename
5470             */
5471           *vmsptr++ = '[';
5472           *vmsptr++ = ']';
5473           vmslen = 2;
5474         }
5475       }
5476     }
5477     else {
5478       /* Handle two special files . and .. */
5479       if (unixptr[0] == '.') {
5480         if (unixptr[1] == '\0') {
5481           *vmsptr++ = '[';
5482           *vmsptr++ = ']';
5483           vmslen += 2;
5484           *vmsptr++ = '\0';
5485           return SS$_NORMAL;
5486         }
5487         if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5488           *vmsptr++ = '[';
5489           *vmsptr++ = '-';
5490           *vmsptr++ = ']';
5491           vmslen += 3;
5492           *vmsptr++ = '\0';
5493           return SS$_NORMAL;
5494         }
5495       }
5496     }
5497   }
5498   else {        /* Absolute PATH handling */
5499   int sts;
5500   char * nextslash;
5501   int seg_len;
5502     /* Need to find out where root is */
5503
5504     /* In theory, this procedure should never get an absolute POSIX pathname
5505      * that can not be found on the POSIX root.
5506      * In practice, that can not be relied on, and things will show up
5507      * here that are a VMS device name or concealed logical name instead.
5508      * So to make things work, this procedure must be tolerant.
5509      */
5510     Newx(esa, vmspath_len, char);
5511
5512     sts = SS$_NORMAL;
5513     nextslash = strchr(&unixptr[1],'/');
5514     seg_len = 0;
5515     if (nextslash != NULL) {
5516       seg_len = nextslash - &unixptr[1];
5517       strncpy(vmspath, unixptr, seg_len + 1);
5518       vmspath[seg_len+1] = 0;
5519       sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5520     }
5521
5522     if (sts & 1) {
5523       /* This is verified to be a real path */
5524
5525       sts = posix_to_vmsspec(esa, vmspath_len, "/");
5526       strcpy(vmspath, esa);
5527       vmslen = strlen(vmspath);
5528       vmsptr = vmspath + vmslen;
5529       unixptr++;
5530       if (unixptr < lastslash) {
5531       char * rptr;
5532         vmsptr--;
5533         *vmsptr++ = '.';
5534         dir_start = 1;
5535         dir_dot = 1;
5536         if (vmslen > 7) {
5537         int cmp;
5538           rptr = vmsptr - 7;
5539           cmp = strcmp(rptr,"000000.");
5540           if (cmp == 0) {
5541             vmslen -= 7;
5542             vmsptr -= 7;
5543             vmsptr[1] = '\0';
5544           } /* removing 6 zeros */
5545         } /* vmslen < 7, no 6 zeros possible */
5546       } /* Not in a directory */
5547     } /* end of verified real path handling */
5548     else {
5549     int add_6zero;
5550     int islnm;
5551
5552       /* Ok, we have a device or a concealed root that is not in POSIX
5553        * or we have garbage.  Make the best of it.
5554        */
5555
5556       /* Posix to VMS destroyed this, so copy it again */
5557       strncpy(vmspath, &unixptr[1], seg_len);
5558       vmspath[seg_len] = 0;
5559       vmslen = seg_len;
5560       vmsptr = &vmsptr[vmslen];
5561       islnm = 0;
5562
5563       /* Now do we need to add the fake 6 zero directory to it? */
5564       add_6zero = 1;
5565       if ((*lastslash == '/') && (nextslash < lastslash)) {
5566         /* No there is another directory */
5567         add_6zero = 0;
5568       }
5569       else {
5570       int trnend;
5571
5572         /* now we have foo:bar or foo:[000000]bar to decide from */
5573         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
5574         trnend = islnm ? islnm - 1 : 0;
5575
5576         /* if this was a logical name, ']' or '>' must be present */
5577         /* if not a logical name, then assume a device and hope. */
5578         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
5579
5580         /* if log name and trailing '.' then rooted - treat as device */
5581         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
5582
5583         /* Fix me, if not a logical name, a device lookup should be
5584          * done to see if the device is file structured.  If the device
5585          * is not file structured, the 6 zeros should not be put on.
5586          *
5587          * As it is, perl is occasionally looking for dev:[000000]tty.
5588          * which looks a little strange.
5589          */
5590
5591         if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
5592           /* No real directory present */
5593           add_6zero = 1;
5594         }
5595       }
5596
5597       /* Put the device delimiter on */
5598       *vmsptr++ = ':';
5599       vmslen++;
5600       unixptr = nextslash;
5601       unixptr++;
5602
5603       /* Start directory if needed */
5604       if (!islnm || add_6zero) {
5605         *vmsptr++ = '[';
5606         vmslen++;
5607         dir_start = 1;
5608       }
5609
5610       /* add fake 000000] if needed */
5611       if (add_6zero) {
5612         *vmsptr++ = '0';
5613         *vmsptr++ = '0';
5614         *vmsptr++ = '0';
5615         *vmsptr++ = '0';
5616         *vmsptr++ = '0';
5617         *vmsptr++ = '0';
5618         *vmsptr++ = ']';
5619         vmslen += 7;
5620         dir_start = 0;
5621       }
5622
5623     } /* non-POSIX translation */
5624     Safefree(esa);
5625   } /* End of relative/absolute path handling */
5626
5627   while ((*unixptr) && (vmslen < vmspath_len)){
5628   int dash_flag;
5629
5630     dash_flag = 0;
5631
5632     if (dir_start != 0) {
5633
5634       /* First characters in a directory are handled special */
5635       while ((*unixptr == '/') ||
5636              ((*unixptr == '.') &&
5637               ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
5638       int loop_flag;
5639
5640         loop_flag = 0;
5641
5642         /* Skip redundant / in specification */
5643         while ((*unixptr == '/') && (dir_start != 0)) {
5644           loop_flag = 1;
5645           unixptr++;
5646           if (unixptr == lastslash)
5647             break;
5648         }
5649         if (unixptr == lastslash)
5650           break;
5651
5652         /* Skip redundant ./ characters */
5653         while ((*unixptr == '.') &&
5654                ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
5655           loop_flag = 1;
5656           unixptr++;
5657           if (unixptr == lastslash)
5658             break;
5659           if (*unixptr == '/')
5660             unixptr++;
5661         }
5662         if (unixptr == lastslash)
5663           break;
5664
5665         /* Skip redundant ../ characters */
5666         while ((*unixptr == '.') && (unixptr[1] == '.') &&
5667              ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
5668           /* Set the backing up flag */
5669           loop_flag = 1;
5670           dir_dot = 0;
5671           dash_flag = 1;
5672           *vmsptr++ = '-';
5673           vmslen++;
5674           unixptr++; /* first . */
5675           unixptr++; /* second . */
5676           if (unixptr == lastslash)
5677             break;
5678           if (*unixptr == '/') /* The slash */
5679             unixptr++;
5680         }
5681         if (unixptr == lastslash)
5682           break;
5683
5684         /* To do: Perl expects /.../ to be translated to [...] on VMS */
5685         /* Not needed when VMS is pretending to be UNIX. */
5686
5687         /* Is this loop stuck because of too many dots? */
5688         if (loop_flag == 0) {
5689           /* Exit the loop and pass the rest through */
5690           break;
5691         }
5692       }
5693
5694       /* Are we done with directories yet? */
5695       if (unixptr >= lastslash) {
5696
5697         /* Watch out for trailing dots */
5698         if (dir_dot != 0) {
5699             vmslen --;
5700             vmsptr--;
5701         }
5702         *vmsptr++ = ']';
5703         vmslen++;
5704         dash_flag = 0;
5705         dir_start = 0;
5706         if (*unixptr == '/')
5707           unixptr++;
5708       }
5709       else {
5710         /* Have we stopped backing up? */
5711         if (dash_flag) {
5712           *vmsptr++ = '.';
5713           vmslen++;
5714           dash_flag = 0;
5715           /* dir_start continues to be = 1 */
5716         }
5717         if (*unixptr == '-') {
5718           *vmsptr++ = '^';
5719           *vmsptr++ = *unixptr++;
5720           vmslen += 2;
5721           dir_start = 0;
5722
5723           /* Now are we done with directories yet? */
5724           if (unixptr >= lastslash) {
5725
5726             /* Watch out for trailing dots */
5727             if (dir_dot != 0) {
5728               vmslen --;
5729               vmsptr--;
5730             }
5731
5732             *vmsptr++ = ']';
5733             vmslen++;
5734             dash_flag = 0;
5735             dir_start = 0;
5736           }
5737         }
5738       }
5739     }
5740
5741     /* All done? */
5742     if (*unixptr == '\0')
5743       break;
5744
5745     /* Normal characters - More EFS work probably needed */
5746     dir_start = 0;
5747     dir_dot = 0;
5748
5749     switch(*unixptr) {
5750     case '/':
5751         /* remove multiple / */
5752         while (unixptr[1] == '/') {
5753            unixptr++;
5754         }
5755         if (unixptr == lastslash) {
5756           /* Watch out for trailing dots */
5757           if (dir_dot != 0) {
5758             vmslen --;
5759             vmsptr--;
5760           }
5761           *vmsptr++ = ']';
5762         }
5763         else {
5764           dir_start = 1;
5765           *vmsptr++ = '.';
5766           dir_dot = 1;
5767
5768           /* To do: Perl expects /.../ to be translated to [...] on VMS */
5769           /* Not needed when VMS is pretending to be UNIX. */
5770
5771         }
5772         dash_flag = 0;
5773         if (*unixptr != '\0')
5774           unixptr++;
5775         vmslen++;
5776         break;
5777     case '?':
5778         *vmsptr++ = '%';
5779         vmslen++;
5780         unixptr++;
5781         break;
5782     case ' ':
5783         *vmsptr++ = '^';
5784         *vmsptr++ = '_';
5785         vmslen += 2;
5786         unixptr++;
5787         break;
5788     case '.':
5789         if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
5790           *vmsptr++ = '^';
5791           *vmsptr++ = '.';
5792           vmslen += 2;
5793           unixptr++;
5794
5795           /* trailing dot ==> '^..' on VMS */
5796           if (*unixptr == '\0') {
5797             *vmsptr++ = '.';
5798             vmslen++;
5799           }
5800           *vmsptr++ = *unixptr++;
5801           vmslen ++;
5802         }
5803         if (quoted && (unixptr[1] == '\0')) {
5804           unixptr++;
5805           break;
5806         }
5807         *vmsptr++ = '^';
5808         *vmsptr++ = *unixptr++;
5809         vmslen += 2;
5810         break;
5811     case '~':
5812     case ';':
5813     case '\\':
5814         *vmsptr++ = '^';
5815         *vmsptr++ = *unixptr++;
5816         vmslen += 2;
5817         break;
5818     default:
5819         if (*unixptr != '\0') {
5820           *vmsptr++ = *unixptr++;
5821           vmslen++;
5822         }
5823         break;
5824     }
5825   }
5826
5827   /* Make sure directory is closed */
5828   if (unixptr == lastslash) {
5829     char *vmsptr2;
5830     vmsptr2 = vmsptr - 1;
5831
5832     if (*vmsptr2 != ']') {
5833       *vmsptr2--;
5834
5835       /* directories do not end in a dot bracket */
5836       if (*vmsptr2 == '.') {
5837         vmsptr2--;
5838
5839         /* ^. is allowed */
5840         if (*vmsptr2 != '^') {
5841           vmsptr--; /* back up over the dot */
5842         }
5843       }
5844       *vmsptr++ = ']';
5845     }
5846   }
5847   else {
5848     char *vmsptr2;
5849     /* Add a trailing dot if a file with no extension */
5850     vmsptr2 = vmsptr - 1;
5851     if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
5852         (*lastdot != '.')) {
5853         *vmsptr++ = '.';
5854         vmslen++;
5855     }
5856   }
5857
5858   *vmsptr = '\0';
5859   return SS$_NORMAL;
5860 }
5861 #endif
5862
5863 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
5864 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
5865   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
5866   char *rslt, *dirend;
5867   char *lastdot;
5868   char *vms_delim;
5869   register char *cp1;
5870   const char *cp2;
5871   unsigned long int infront = 0, hasdir = 1;
5872   int rslt_len;
5873   int no_type_seen;
5874
5875   if (path == NULL) return NULL;
5876   rslt_len = VMS_MAXRSS;
5877   if (buf) rslt = buf;
5878   else if (ts) Newx(rslt,NAM$C_MAXRSS+1,char);
5879   else rslt = __tovmsspec_retbuf;
5880   if (strpbrk(path,"]:>") ||
5881       (dirend = strrchr(path,'/')) == NULL) {
5882     if (path[0] == '.') {
5883       if (path[1] == '\0') strcpy(rslt,"[]");
5884       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
5885       else strcpy(rslt,path); /* probably garbage */
5886     }
5887     else strcpy(rslt,path);
5888     return rslt;
5889   }
5890
5891    /* Posix specifications are now a native VMS format */
5892   /*--------------------------------------------------*/
5893 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5894   if (decc_posix_compliant_pathnames) {
5895     if (strncmp(path,"\"^UP^",5) == 0) {
5896       posix_to_vmsspec_hardway(rslt, rslt_len, path);
5897       return rslt;
5898     }
5899   }
5900 #endif
5901
5902   vms_delim = strpbrk(path,"]:>");
5903
5904   if ((vms_delim != NULL) ||
5905       ((dirend = strrchr(path,'/')) == NULL)) {
5906
5907     /* VMS special characters found! */
5908
5909     if (path[0] == '.') {
5910       if (path[1] == '\0') strcpy(rslt,"[]");
5911       else if (path[1] == '.' && path[2] == '\0')
5912         strcpy(rslt,"[-]");
5913
5914       /* Dot preceeding a device or directory ? */
5915       else {
5916         /* If not in POSIX mode, pass it through and hope it works */
5917 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5918         if (!decc_posix_compliant_pathnames)
5919           strcpy(rslt,path); /* probably garbage */
5920         else
5921           posix_to_vmsspec_hardway(rslt, rslt_len, path);
5922 #else
5923         strcpy(rslt,path); /* probably garbage */
5924 #endif
5925       }
5926     }
5927     else {
5928
5929        /* If no VMS characters and in POSIX mode, convert it!
5930         * This is the easiest way to get directory specifications
5931         * handled correctly in POSIX mode
5932         */
5933 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5934       if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
5935         posix_to_vmsspec_hardway(rslt, rslt_len, path);
5936       else {
5937         /* No unix path separators - presume VMS already */
5938         strcpy(rslt,path);
5939       }
5940 #else
5941       strcpy(rslt,path); /* probably garbage */
5942 #endif
5943     }
5944     return rslt;
5945   }
5946
5947 /* If POSIX mode active, handle the conversion */
5948 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5949   if (decc_posix_compliant_pathnames) {
5950     posix_to_vmsspec_hardway(rslt, rslt_len, path);
5951     return rslt;
5952   }
5953 #endif
5954
5955   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
5956     if (!*(dirend+2)) dirend +=2;
5957     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
5958     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
5959   }
5960
5961   cp1 = rslt;
5962   cp2 = path;
5963   lastdot = strrchr(cp2,'.');
5964   if (*cp2 == '/') {
5965     char trndev[NAM$C_MAXRSS+1];
5966     int islnm, rooted;
5967     STRLEN trnend;
5968
5969     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
5970     if (!*(cp2+1)) {
5971       if (decc_disable_posix_root) {
5972         strcpy(rslt,"sys$disk:[000000]");
5973       }
5974       else {
5975         strcpy(rslt,"sys$posix_root:[000000]");
5976       }
5977       return rslt;
5978     }
5979     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
5980     *cp1 = '\0';
5981     islnm =  my_trnlnm(rslt,trndev,0);
5982
5983      /* DECC special handling */
5984     if (!islnm) {
5985       if (strcmp(rslt,"bin") == 0) {
5986         strcpy(rslt,"sys$system");
5987         cp1 = rslt + 10;
5988         *cp1 = 0;
5989         islnm =  my_trnlnm(rslt,trndev,0);
5990       }
5991       else if (strcmp(rslt,"tmp") == 0) {
5992         strcpy(rslt,"sys$scratch");
5993         cp1 = rslt + 11;
5994         *cp1 = 0;
5995         islnm =  my_trnlnm(rslt,trndev,0);
5996       }
5997       else if (!decc_disable_posix_root) {
5998         strcpy(rslt, "sys$posix_root");
5999         cp1 = rslt + 13;
6000         *cp1 = 0;
6001         cp2 = path;
6002         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6003         islnm =  my_trnlnm(rslt,trndev,0);
6004       }
6005       else if (strcmp(rslt,"dev") == 0) {
6006         if (strncmp(cp2,"/null", 5) == 0) {
6007           if ((cp2[5] == 0) || (cp2[5] == '/')) {
6008             strcpy(rslt,"NLA0");
6009             cp1 = rslt + 4;
6010             *cp1 = 0;
6011             cp2 = cp2 + 5;
6012             islnm =  my_trnlnm(rslt,trndev,0);
6013           }
6014         }
6015       }
6016     }
6017
6018     trnend = islnm ? strlen(trndev) - 1 : 0;
6019     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6020     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6021     /* If the first element of the path is a logical name, determine
6022      * whether it has to be translated so we can add more directories. */
6023     if (!islnm || rooted) {
6024       *(cp1++) = ':';
6025       *(cp1++) = '[';
6026       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6027       else cp2++;
6028     }
6029     else {
6030       if (cp2 != dirend) {
6031         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
6032         strcpy(rslt,trndev);
6033         cp1 = rslt + trnend;
6034         if (*cp2 != 0) {
6035           *(cp1++) = '.';
6036           cp2++;
6037         }
6038       }
6039       else {
6040         if (decc_disable_posix_root) {
6041           *(cp1++) = ':';
6042           hasdir = 0;
6043         }
6044       }
6045     }
6046   }
6047   else {
6048     *(cp1++) = '[';
6049     if (*cp2 == '.') {
6050       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6051         cp2 += 2;         /* skip over "./" - it's redundant */
6052         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
6053       }
6054       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6055         *(cp1++) = '-';                                 /* "../" --> "-" */
6056         cp2 += 3;
6057       }
6058       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6059                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6060         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6061         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6062         cp2 += 4;
6063       }
6064       else if ((cp2 != lastdot) || (lastdot < dirend)) {
6065         /* Escape the extra dots in EFS file specifications */
6066         *(cp1++) = '^';
6067       }
6068       if (cp2 > dirend) cp2 = dirend;
6069     }
6070     else *(cp1++) = '.';
6071   }
6072   for (; cp2 < dirend; cp2++) {
6073     if (*cp2 == '/') {
6074       if (*(cp2-1) == '/') continue;
6075       if (*(cp1-1) != '.') *(cp1++) = '.';
6076       infront = 0;
6077     }
6078     else if (!infront && *cp2 == '.') {
6079       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6080       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
6081       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6082         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6083         else if (*(cp1-2) == '[') *(cp1-1) = '-';
6084         else {  /* back up over previous directory name */
6085           cp1--;
6086           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6087           if (*(cp1-1) == '[') {
6088             memcpy(cp1,"000000.",7);
6089             cp1 += 7;
6090           }
6091         }
6092         cp2 += 2;
6093         if (cp2 == dirend) break;
6094       }
6095       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6096                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6097         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6098         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6099         if (!*(cp2+3)) {
6100           *(cp1++) = '.';  /* Simulate trailing '/' */
6101           cp2 += 2;  /* for loop will incr this to == dirend */
6102         }
6103         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
6104       }
6105       else {
6106         if (decc_efs_charset == 0)
6107           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
6108         else {
6109           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
6110           *(cp1++) = '.';
6111         }
6112       }
6113     }
6114     else {
6115       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
6116       if (*cp2 == '.') {
6117         if (decc_efs_charset == 0)
6118           *(cp1++) = '_';
6119         else {
6120           *(cp1++) = '^';
6121           *(cp1++) = '.';
6122         }
6123       }
6124       else                  *(cp1++) =  *cp2;
6125       infront = 1;
6126     }
6127   }
6128   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6129   if (hasdir) *(cp1++) = ']';
6130   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
6131   /* fixme for ODS5 */
6132   no_type_seen = 0;
6133   if (cp2 > lastdot)
6134     no_type_seen = 1;
6135   while (*cp2) {
6136     switch(*cp2) {
6137     case '?':
6138         *(cp1++) = '%';
6139         cp2++;
6140     case ' ':
6141         *(cp1)++ = '^';
6142         *(cp1)++ = '_';
6143         cp2++;
6144         break;
6145     case '.':
6146         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6147             decc_readdir_dropdotnotype) {
6148           *(cp1)++ = '^';
6149           *(cp1)++ = '.';
6150           cp2++;
6151
6152           /* trailing dot ==> '^..' on VMS */
6153           if (*cp2 == '\0') {
6154             *(cp1++) = '.';
6155             no_type_seen = 0;
6156           }
6157         }
6158         else {
6159           *(cp1++) = *(cp2++);
6160           no_type_seen = 0;
6161         }
6162         break;
6163     case '\"':
6164     case '~':
6165     case '`':
6166     case '!':
6167     case '#':
6168     case '%':
6169     case '^':
6170     case '&':
6171     case '(':
6172     case ')':
6173     case '=':
6174     case '+':
6175     case '\'':
6176     case '@':
6177     case '[':
6178     case ']':
6179     case '{':
6180     case '}':
6181     case ':':
6182     case '\\':
6183     case '|':
6184     case '<':
6185     case '>':
6186         *(cp1++) = '^';
6187         *(cp1++) = *(cp2++);
6188         break;
6189     case ';':
6190         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6191          * which is wrong.  UNIX notation should be ".dir. unless
6192          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6193          * changing this behavior could break more things at this time.
6194          * efs character set effectively does not allow "." to be a version
6195          * delimiter as a further complication about changing this.
6196          */
6197         if (decc_filename_unix_report != 0) {
6198           *(cp1++) = '^';
6199         }
6200         *(cp1++) = *(cp2++);
6201         break;
6202     default:
6203         *(cp1++) = *(cp2++);
6204     }
6205   }
6206   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6207   char *lcp1;
6208     lcp1 = cp1;
6209     lcp1--;
6210      /* Fix me for "^]", but that requires making sure that you do
6211       * not back up past the start of the filename
6212       */
6213     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6214       *cp1++ = '.';
6215   }
6216   *cp1 = '\0';
6217
6218   return rslt;
6219
6220 }  /* end of do_tovmsspec() */
6221 /*}}}*/
6222 /* External entry points */
6223 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6224 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6225
6226 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6227 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6228   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
6229   int vmslen;
6230   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
6231
6232   if (path == NULL) return NULL;
6233   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
6234   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
6235   if (buf) return buf;
6236   else if (ts) {
6237     vmslen = strlen(vmsified);
6238     Newx(cp,vmslen+1,char);
6239     memcpy(cp,vmsified,vmslen);
6240     cp[vmslen] = '\0';
6241     return cp;
6242   }
6243   else {
6244     strcpy(__tovmspath_retbuf,vmsified);
6245     return __tovmspath_retbuf;
6246   }
6247
6248 }  /* end of do_tovmspath() */
6249 /*}}}*/
6250 /* External entry points */
6251 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6252 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6253
6254
6255 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6256 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6257   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
6258   int unixlen;
6259   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
6260
6261   if (path == NULL) return NULL;
6262   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
6263   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
6264   if (buf) return buf;
6265   else if (ts) {
6266     unixlen = strlen(unixified);
6267     Newx(cp,unixlen+1,char);
6268     memcpy(cp,unixified,unixlen);
6269     cp[unixlen] = '\0';
6270     return cp;
6271   }
6272   else {
6273     strcpy(__tounixpath_retbuf,unixified);
6274     return __tounixpath_retbuf;
6275   }
6276
6277 }  /* end of do_tounixpath() */
6278 /*}}}*/
6279 /* External entry points */
6280 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6281 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6282
6283 /*
6284  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
6285  *
6286  *****************************************************************************
6287  *                                                                           *
6288  *  Copyright (C) 1989-1994 by                                               *
6289  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
6290  *                                                                           *
6291  *  Permission is hereby  granted for the reproduction of this software,     *
6292  *  on condition that this copyright notice is included in the reproduction, *
6293  *  and that such reproduction is not for purposes of profit or material     *
6294  *  gain.                                                                    *
6295  *                                                                           *
6296  *  27-Aug-1994 Modified for inclusion in perl5                              *
6297  *              by Charles Bailey  bailey@newman.upenn.edu                   *
6298  *****************************************************************************
6299  */
6300
6301 /*
6302  * getredirection() is intended to aid in porting C programs
6303  * to VMS (Vax-11 C).  The native VMS environment does not support
6304  * '>' and '<' I/O redirection, or command line wild card expansion,
6305  * or a command line pipe mechanism using the '|' AND background
6306  * command execution '&'.  All of these capabilities are provided to any
6307  * C program which calls this procedure as the first thing in the
6308  * main program.
6309  * The piping mechanism will probably work with almost any 'filter' type
6310  * of program.  With suitable modification, it may useful for other
6311  * portability problems as well.
6312  *
6313  * Author:  Mark Pizzolato      mark@infocomm.com
6314  */
6315 struct list_item
6316     {
6317     struct list_item *next;
6318     char *value;
6319     };
6320
6321 static void add_item(struct list_item **head,
6322                      struct list_item **tail,
6323                      char *value,
6324                      int *count);
6325
6326 static void mp_expand_wild_cards(pTHX_ char *item,
6327                                 struct list_item **head,
6328                                 struct list_item **tail,
6329                                 int *count);
6330
6331 static int background_process(pTHX_ int argc, char **argv);
6332
6333 static void pipe_and_fork(pTHX_ char **cmargv);
6334
6335 /*{{{ void getredirection(int *ac, char ***av)*/
6336 static void
6337 mp_getredirection(pTHX_ int *ac, char ***av)
6338 /*
6339  * Process vms redirection arg's.  Exit if any error is seen.
6340  * If getredirection() processes an argument, it is erased
6341  * from the vector.  getredirection() returns a new argc and argv value.
6342  * In the event that a background command is requested (by a trailing "&"),
6343  * this routine creates a background subprocess, and simply exits the program.
6344  *
6345  * Warning: do not try to simplify the code for vms.  The code
6346  * presupposes that getredirection() is called before any data is
6347  * read from stdin or written to stdout.
6348  *
6349  * Normal usage is as follows:
6350  *
6351  *      main(argc, argv)
6352  *      int             argc;
6353  *      char            *argv[];
6354  *      {
6355  *              getredirection(&argc, &argv);
6356  *      }
6357  */
6358 {
6359     int                 argc = *ac;     /* Argument Count         */
6360     char                **argv = *av;   /* Argument Vector        */
6361     char                *ap;            /* Argument pointer       */
6362     int                 j;              /* argv[] index           */
6363     int                 item_count = 0; /* Count of Items in List */
6364     struct list_item    *list_head = 0; /* First Item in List       */
6365     struct list_item    *list_tail;     /* Last Item in List        */
6366     char                *in = NULL;     /* Input File Name          */
6367     char                *out = NULL;    /* Output File Name         */
6368     char                *outmode = "w"; /* Mode to Open Output File */
6369     char                *err = NULL;    /* Error File Name          */
6370     char                *errmode = "w"; /* Mode to Open Error File  */
6371     int                 cmargc = 0;     /* Piped Command Arg Count  */
6372     char                **cmargv = NULL;/* Piped Command Arg Vector */
6373
6374     /*
6375      * First handle the case where the last thing on the line ends with
6376      * a '&'.  This indicates the desire for the command to be run in a
6377      * subprocess, so we satisfy that desire.
6378      */
6379     ap = argv[argc-1];
6380     if (0 == strcmp("&", ap))
6381        exit(background_process(aTHX_ --argc, argv));
6382     if (*ap && '&' == ap[strlen(ap)-1])
6383         {
6384         ap[strlen(ap)-1] = '\0';
6385        exit(background_process(aTHX_ argc, argv));
6386         }
6387     /*
6388      * Now we handle the general redirection cases that involve '>', '>>',
6389      * '<', and pipes '|'.
6390      */
6391     for (j = 0; j < argc; ++j)
6392         {
6393         if (0 == strcmp("<", argv[j]))
6394             {
6395             if (j+1 >= argc)
6396                 {
6397                 fprintf(stderr,"No input file after < on command line");
6398                 exit(LIB$_WRONUMARG);
6399                 }
6400             in = argv[++j];
6401             continue;
6402             }
6403         if ('<' == *(ap = argv[j]))
6404             {
6405             in = 1 + ap;
6406             continue;
6407             }
6408         if (0 == strcmp(">", ap))
6409             {
6410             if (j+1 >= argc)
6411                 {
6412                 fprintf(stderr,"No output file after > on command line");
6413                 exit(LIB$_WRONUMARG);
6414                 }
6415             out = argv[++j];
6416             continue;
6417             }
6418         if ('>' == *ap)
6419             {
6420             if ('>' == ap[1])
6421                 {
6422                 outmode = "a";
6423                 if ('\0' == ap[2])
6424                     out = argv[++j];
6425                 else
6426                     out = 2 + ap;
6427                 }
6428             else
6429                 out = 1 + ap;
6430             if (j >= argc)
6431                 {
6432                 fprintf(stderr,"No output file after > or >> on command line");
6433                 exit(LIB$_WRONUMARG);
6434                 }
6435             continue;
6436             }
6437         if (('2' == *ap) && ('>' == ap[1]))
6438             {
6439             if ('>' == ap[2])
6440                 {
6441                 errmode = "a";
6442                 if ('\0' == ap[3])
6443                     err = argv[++j];
6444                 else
6445                     err = 3 + ap;
6446                 }
6447             else
6448                 if ('\0' == ap[2])
6449                     err = argv[++j];
6450                 else
6451                     err = 2 + ap;
6452             if (j >= argc)
6453                 {
6454                 fprintf(stderr,"No output file after 2> or 2>> on command line");
6455                 exit(LIB$_WRONUMARG);
6456                 }
6457             continue;
6458             }
6459         if (0 == strcmp("|", argv[j]))
6460             {
6461             if (j+1 >= argc)
6462                 {
6463                 fprintf(stderr,"No command into which to pipe on command line");
6464                 exit(LIB$_WRONUMARG);
6465                 }
6466             cmargc = argc-(j+1);
6467             cmargv = &argv[j+1];
6468             argc = j;
6469             continue;
6470             }
6471         if ('|' == *(ap = argv[j]))
6472             {
6473             ++argv[j];
6474             cmargc = argc-j;
6475             cmargv = &argv[j];
6476             argc = j;
6477             continue;
6478             }
6479         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6480         }
6481     /*
6482      * Allocate and fill in the new argument vector, Some Unix's terminate
6483      * the list with an extra null pointer.
6484      */
6485     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
6486     *av = argv;
6487     for (j = 0; j < item_count; ++j, list_head = list_head->next)
6488         argv[j] = list_head->value;
6489     *ac = item_count;
6490     if (cmargv != NULL)
6491         {
6492         if (out != NULL)
6493             {
6494             fprintf(stderr,"'|' and '>' may not both be specified on command line");
6495             exit(LIB$_INVARGORD);
6496             }
6497         pipe_and_fork(aTHX_ cmargv);
6498         }
6499
6500     /* Check for input from a pipe (mailbox) */
6501
6502     if (in == NULL && 1 == isapipe(0))
6503         {
6504         char mbxname[L_tmpnam];
6505         long int bufsize;
6506         long int dvi_item = DVI$_DEVBUFSIZ;
6507         $DESCRIPTOR(mbxnam, "");
6508         $DESCRIPTOR(mbxdevnam, "");
6509
6510         /* Input from a pipe, reopen it in binary mode to disable       */
6511         /* carriage control processing.                                 */
6512
6513         fgetname(stdin, mbxname);
6514         mbxnam.dsc$a_pointer = mbxname;
6515         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6516         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6517         mbxdevnam.dsc$a_pointer = mbxname;
6518         mbxdevnam.dsc$w_length = sizeof(mbxname);
6519         dvi_item = DVI$_DEVNAM;
6520         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6521         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
6522         set_errno(0);
6523         set_vaxc_errno(1);
6524         freopen(mbxname, "rb", stdin);
6525         if (errno != 0)
6526             {
6527             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
6528             exit(vaxc$errno);
6529             }
6530         }
6531     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6532         {
6533         fprintf(stderr,"Can't open input file %s as stdin",in);
6534         exit(vaxc$errno);
6535         }
6536     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
6537         {
6538         fprintf(stderr,"Can't open output file %s as stdout",out);
6539         exit(vaxc$errno);
6540         }
6541         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
6542
6543     if (err != NULL) {
6544         if (strcmp(err,"&1") == 0) {
6545             dup2(fileno(stdout), fileno(stderr));
6546             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
6547         } else {
6548         FILE *tmperr;
6549         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
6550             {
6551             fprintf(stderr,"Can't open error file %s as stderr",err);
6552             exit(vaxc$errno);
6553             }
6554             fclose(tmperr);
6555            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
6556                 {
6557                 exit(vaxc$errno);
6558                 }
6559             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
6560         }
6561         }
6562 #ifdef ARGPROC_DEBUG
6563     PerlIO_printf(Perl_debug_log, "Arglist:\n");
6564     for (j = 0; j < *ac;  ++j)
6565         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
6566 #endif
6567    /* Clear errors we may have hit expanding wildcards, so they don't
6568       show up in Perl's $! later */
6569    set_errno(0); set_vaxc_errno(1);
6570 }  /* end of getredirection() */
6571 /*}}}*/
6572
6573 static void add_item(struct list_item **head,
6574                      struct list_item **tail,
6575                      char *value,
6576                      int *count)
6577 {
6578     if (*head == 0)
6579         {
6580         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6581         *tail = *head;
6582         }
6583     else {
6584         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6585         *tail = (*tail)->next;
6586         }
6587     (*tail)->value = value;
6588     ++(*count);
6589 }
6590
6591 static void mp_expand_wild_cards(pTHX_ char *item,
6592                               struct list_item **head,
6593                               struct list_item **tail,
6594                               int *count)
6595 {
6596 int expcount = 0;
6597 unsigned long int context = 0;
6598 int isunix = 0;
6599 int item_len = 0;
6600 char *had_version;
6601 char *had_device;
6602 int had_directory;
6603 char *devdir,*cp;
6604 char vmsspec[NAM$C_MAXRSS+1];
6605 $DESCRIPTOR(filespec, "");
6606 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
6607 $DESCRIPTOR(resultspec, "");
6608 unsigned long int zero = 0, sts;
6609
6610     for (cp = item; *cp; cp++) {
6611         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
6612         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
6613     }
6614     if (!*cp || isspace(*cp))
6615         {
6616         add_item(head, tail, item, count);
6617         return;
6618         }
6619     else
6620         {
6621      /* "double quoted" wild card expressions pass as is */
6622      /* From DCL that means using e.g.:                  */
6623      /* perl program """perl.*"""                        */
6624      item_len = strlen(item);
6625      if ( '"' == *item && '"' == item[item_len-1] )
6626        {
6627        item++;
6628        item[item_len-2] = '\0';
6629        add_item(head, tail, item, count);
6630        return;
6631        }
6632      }
6633     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
6634     resultspec.dsc$b_class = DSC$K_CLASS_D;
6635     resultspec.dsc$a_pointer = NULL;
6636     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
6637       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
6638     if (!isunix || !filespec.dsc$a_pointer)
6639       filespec.dsc$a_pointer = item;
6640     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
6641     /*
6642      * Only return version specs, if the caller specified a version
6643      */
6644     had_version = strchr(item, ';');
6645     /*
6646      * Only return device and directory specs, if the caller specifed either.
6647      */
6648     had_device = strchr(item, ':');
6649     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
6650
6651     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
6652                                   &defaultspec, 0, 0, &zero))))
6653         {
6654         char *string;
6655         char *c;
6656
6657         Newx(string,resultspec.dsc$w_length+1,char);
6658         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
6659         string[resultspec.dsc$w_length] = '\0';
6660         if (NULL == had_version)
6661             *(strrchr(string, ';')) = '\0';
6662         if ((!had_directory) && (had_device == NULL))
6663             {
6664             if (NULL == (devdir = strrchr(string, ']')))
6665                 devdir = strrchr(string, '>');
6666             strcpy(string, devdir + 1);
6667             }
6668         /*
6669          * Be consistent with what the C RTL has already done to the rest of
6670          * the argv items and lowercase all of these names.
6671          */
6672         if (!decc_efs_case_preserve) {
6673             for (c = string; *c; ++c)
6674             if (isupper(*c))
6675                 *c = tolower(*c);
6676         }
6677         if (isunix) trim_unixpath(string,item,1);
6678         add_item(head, tail, string, count);
6679         ++expcount;
6680         }
6681     if (sts != RMS$_NMF)
6682         {
6683         set_vaxc_errno(sts);
6684         switch (sts)
6685             {
6686             case RMS$_FNF: case RMS$_DNF:
6687                 set_errno(ENOENT); break;
6688             case RMS$_DIR:
6689                 set_errno(ENOTDIR); break;
6690             case RMS$_DEV:
6691                 set_errno(ENODEV); break;
6692             case RMS$_FNM: case RMS$_SYN:
6693                 set_errno(EINVAL); break;
6694             case RMS$_PRV:
6695                 set_errno(EACCES); break;
6696             default:
6697                 _ckvmssts_noperl(sts);
6698             }
6699         }
6700     if (expcount == 0)
6701         add_item(head, tail, item, count);
6702     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
6703     _ckvmssts_noperl(lib$find_file_end(&context));
6704 }
6705
6706 static int child_st[2];/* Event Flag set when child process completes   */
6707
6708 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
6709
6710 static unsigned long int exit_handler(int *status)
6711 {
6712 short iosb[4];
6713
6714     if (0 == child_st[0])
6715         {
6716 #ifdef ARGPROC_DEBUG
6717         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
6718 #endif
6719         fflush(stdout);     /* Have to flush pipe for binary data to    */
6720                             /* terminate properly -- <tp@mccall.com>    */
6721         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
6722         sys$dassgn(child_chan);
6723         fclose(stdout);
6724         sys$synch(0, child_st);
6725         }
6726     return(1);
6727 }
6728
6729 static void sig_child(int chan)
6730 {
6731 #ifdef ARGPROC_DEBUG
6732     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
6733 #endif
6734     if (child_st[0] == 0)
6735         child_st[0] = 1;
6736 }
6737
6738 static struct exit_control_block exit_block =
6739     {
6740     0,
6741     exit_handler,
6742     1,
6743     &exit_block.exit_status,
6744     0
6745     };
6746
6747 static void
6748 pipe_and_fork(pTHX_ char **cmargv)
6749 {
6750     PerlIO *fp;
6751     struct dsc$descriptor_s *vmscmd;
6752     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
6753     int sts, j, l, ismcr, quote, tquote = 0;
6754
6755     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
6756     vms_execfree(vmscmd);
6757
6758     j = l = 0;
6759     p = subcmd;
6760     q = cmargv[0];
6761     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
6762               && toupper(*(q+2)) == 'R' && !*(q+3);
6763
6764     while (q && l < MAX_DCL_LINE_LENGTH) {
6765         if (!*q) {
6766             if (j > 0 && quote) {
6767                 *p++ = '"';
6768                 l++;
6769             }
6770             q = cmargv[++j];
6771             if (q) {
6772                 if (ismcr && j > 1) quote = 1;
6773                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
6774                 *p++ = ' ';
6775                 l++;
6776                 if (quote || tquote) {
6777                     *p++ = '"';
6778                     l++;
6779                 }
6780         }
6781         } else {
6782             if ((quote||tquote) && *q == '"') {
6783                 *p++ = '"';
6784                 l++;
6785         }
6786             *p++ = *q++;
6787             l++;
6788         }
6789     }
6790     *p = '\0';
6791
6792     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
6793     if (fp == Nullfp) {
6794         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
6795         }
6796 }
6797
6798 static int background_process(pTHX_ int argc, char **argv)
6799 {
6800 char command[2048] = "$";
6801 $DESCRIPTOR(value, "");
6802 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
6803 static $DESCRIPTOR(null, "NLA0:");
6804 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
6805 char pidstring[80];
6806 $DESCRIPTOR(pidstr, "");
6807 int pid;
6808 unsigned long int flags = 17, one = 1, retsts;
6809
6810     strcat(command, argv[0]);
6811     while (--argc)
6812         {
6813         strcat(command, " \"");
6814         strcat(command, *(++argv));
6815         strcat(command, "\"");
6816         }
6817     value.dsc$a_pointer = command;
6818     value.dsc$w_length = strlen(value.dsc$a_pointer);
6819     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
6820     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
6821     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
6822         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
6823     }
6824     else {
6825         _ckvmssts_noperl(retsts);
6826     }
6827 #ifdef ARGPROC_DEBUG
6828     PerlIO_printf(Perl_debug_log, "%s\n", command);
6829 #endif
6830     sprintf(pidstring, "%08X", pid);
6831     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
6832     pidstr.dsc$a_pointer = pidstring;
6833     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
6834     lib$set_symbol(&pidsymbol, &pidstr);
6835     return(SS$_NORMAL);
6836 }
6837 /*}}}*/
6838 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
6839
6840
6841 /* OS-specific initialization at image activation (not thread startup) */
6842 /* Older VAXC header files lack these constants */
6843 #ifndef JPI$_RIGHTS_SIZE
6844 #  define JPI$_RIGHTS_SIZE 817
6845 #endif
6846 #ifndef KGB$M_SUBSYSTEM
6847 #  define KGB$M_SUBSYSTEM 0x8
6848 #endif
6849
6850 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
6851
6852 /*{{{void vms_image_init(int *, char ***)*/
6853 void
6854 vms_image_init(int *argcp, char ***argvp)
6855 {
6856   char eqv[LNM$C_NAMLENGTH+1] = "";
6857   unsigned int len, tabct = 8, tabidx = 0;
6858   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
6859   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
6860   unsigned short int dummy, rlen;
6861   struct dsc$descriptor_s **tabvec;
6862 #if defined(PERL_IMPLICIT_CONTEXT)
6863   pTHX = NULL;
6864 #endif
6865   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
6866                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
6867                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
6868                                  {          0,                0,    0,      0} };
6869
6870 #ifdef KILL_BY_SIGPRC
6871     Perl_csighandler_init();
6872 #endif
6873
6874   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
6875   _ckvmssts_noperl(iosb[0]);
6876   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
6877     if (iprv[i]) {           /* Running image installed with privs? */
6878       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
6879       will_taint = TRUE;
6880       break;
6881     }
6882   }
6883   /* Rights identifiers might trigger tainting as well. */
6884   if (!will_taint && (rlen || rsz)) {
6885     while (rlen < rsz) {
6886       /* We didn't get all the identifiers on the first pass.  Allocate a
6887        * buffer much larger than $GETJPI wants (rsz is size in bytes that
6888        * were needed to hold all identifiers at time of last call; we'll
6889        * allocate that many unsigned long ints), and go back and get 'em.
6890        * If it gave us less than it wanted to despite ample buffer space,
6891        * something's broken.  Is your system missing a system identifier?
6892        */
6893       if (rsz <= jpilist[1].buflen) {
6894          /* Perl_croak accvios when used this early in startup. */
6895          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
6896                          rsz, (unsigned long) jpilist[1].buflen,
6897                          "Check your rights database for corruption.\n");
6898          exit(SS$_ABORT);
6899       }
6900       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
6901       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
6902       jpilist[1].buflen = rsz * sizeof(unsigned long int);
6903       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
6904       _ckvmssts_noperl(iosb[0]);
6905     }
6906     mask = jpilist[1].bufadr;
6907     /* Check attribute flags for each identifier (2nd longword); protected
6908      * subsystem identifiers trigger tainting.
6909      */
6910     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
6911       if (mask[i] & KGB$M_SUBSYSTEM) {
6912         will_taint = TRUE;
6913         break;
6914       }
6915     }
6916     if (mask != rlst) Safefree(mask);
6917   }
6918
6919   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
6920    * logical, some versions of the CRTL will add a phanthom /000000/
6921    * directory.  This needs to be removed.
6922    */
6923   if (decc_filename_unix_report) {
6924   char * zeros;
6925   int ulen;
6926     ulen = strlen(argvp[0][0]);
6927     if (ulen > 7) {
6928       zeros = strstr(argvp[0][0], "/000000/");
6929       if (zeros != NULL) {
6930         int mlen;
6931         mlen = ulen - (zeros - argvp[0][0]) - 7;
6932         memmove(zeros, &zeros[7], mlen);
6933         ulen = ulen - 7;
6934         argvp[0][0][ulen] = '\0';
6935       }
6936     }
6937     /* It also may have a trailing dot that needs to be removed otherwise
6938      * it will be converted to VMS mode incorrectly.
6939      */
6940     ulen--;
6941     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
6942       argvp[0][0][ulen] = '\0';
6943   }
6944
6945   /* We need to use this hack to tell Perl it should run with tainting,
6946    * since its tainting flag may be part of the PL_curinterp struct, which
6947    * hasn't been allocated when vms_image_init() is called.
6948    */
6949   if (will_taint) {
6950     char **newargv, **oldargv;
6951     oldargv = *argvp;
6952     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
6953     newargv[0] = oldargv[0];
6954     newargv[1] = (char *) PerlMem_malloc(3 * sizeof(char));
6955     strcpy(newargv[1], "-T");
6956     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
6957     (*argcp)++;
6958     newargv[*argcp] = NULL;
6959     /* We orphan the old argv, since we don't know where it's come from,
6960      * so we don't know how to free it.
6961      */
6962     *argvp = newargv;
6963   }
6964   else {  /* Did user explicitly request tainting? */
6965     int i;
6966     char *cp, **av = *argvp;
6967     for (i = 1; i < *argcp; i++) {
6968       if (*av[i] != '-') break;
6969       for (cp = av[i]+1; *cp; cp++) {
6970         if (*cp == 'T') { will_taint = 1; break; }
6971         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
6972                   strchr("DFIiMmx",*cp)) break;
6973       }
6974       if (will_taint) break;
6975     }
6976   }
6977
6978   for (tabidx = 0;
6979        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
6980        tabidx++) {
6981     if (!tabidx) tabvec = (struct dsc$descriptor_s **) PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
6982     else if (tabidx >= tabct) {
6983       tabct += 8;
6984       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
6985     }
6986     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
6987     tabvec[tabidx]->dsc$w_length  = 0;
6988     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
6989     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
6990     tabvec[tabidx]->dsc$a_pointer = NULL;
6991     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
6992   }
6993   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
6994
6995   getredirection(argcp,argvp);
6996 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
6997   {
6998 # include <reentrancy.h>
6999   decc$set_reentrancy(C$C_MULTITHREAD);
7000   }
7001 #endif
7002   return;
7003 }
7004 /*}}}*/
7005
7006
7007 /* trim_unixpath()
7008  * Trim Unix-style prefix off filespec, so it looks like what a shell
7009  * glob expansion would return (i.e. from specified prefix on, not
7010  * full path).  Note that returned filespec is Unix-style, regardless
7011  * of whether input filespec was VMS-style or Unix-style.
7012  *
7013  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7014  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
7015  * vector of options; at present, only bit 0 is used, and if set tells
7016  * trim unixpath to try the current default directory as a prefix when
7017  * presented with a possibly ambiguous ... wildcard.
7018  *
7019  * Returns !=0 on success, with trimmed filespec replacing contents of
7020  * fspec, and 0 on failure, with contents of fpsec unchanged.
7021  */
7022 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7023 int
7024 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7025 {
7026   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
7027        *template, *base, *end, *cp1, *cp2;
7028   register int tmplen, reslen = 0, dirs = 0;
7029
7030   if (!wildspec || !fspec) return 0;
7031   template = unixwild;
7032   if (strpbrk(wildspec,"]>:") != NULL) {
7033     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
7034   }
7035   else {
7036     strncpy(unixwild, wildspec, NAM$C_MAXRSS);
7037     unixwild[NAM$C_MAXRSS] = 0;
7038   }
7039   if (strpbrk(fspec,"]>:") != NULL) {
7040     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
7041     else base = unixified;
7042     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7043      * check to see that final result fits into (isn't longer than) fspec */
7044     reslen = strlen(fspec);
7045   }
7046   else base = fspec;
7047
7048   /* No prefix or absolute path on wildcard, so nothing to remove */
7049   if (!*template || *template == '/') {
7050     if (base == fspec) return 1;
7051     tmplen = strlen(unixified);
7052     if (tmplen > reslen) return 0;  /* not enough space */
7053     /* Copy unixified resultant, including trailing NUL */
7054     memmove(fspec,unixified,tmplen+1);
7055     return 1;
7056   }
7057
7058   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
7059   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7060     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7061     for (cp1 = end ;cp1 >= base; cp1--)
7062       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7063         { cp1++; break; }
7064     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7065     return 1;
7066   }
7067   else {
7068     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
7069     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7070     int ells = 1, totells, segdirs, match;
7071     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
7072                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7073
7074     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7075     totells = ells;
7076     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7077     if (ellipsis == template && opts & 1) {
7078       /* Template begins with an ellipsis.  Since we can't tell how many
7079        * directory names at the front of the resultant to keep for an
7080        * arbitrary starting point, we arbitrarily choose the current
7081        * default directory as a starting point.  If it's there as a prefix,
7082        * clip it off.  If not, fall through and act as if the leading
7083        * ellipsis weren't there (i.e. return shortest possible path that
7084        * could match template).
7085        */
7086       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
7087       if (!decc_efs_case_preserve) {
7088         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7089           if (_tolower(*cp1) != _tolower(*cp2)) break;
7090       }
7091       segdirs = dirs - totells;  /* Min # of dirs we must have left */
7092       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7093       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7094         memmove(fspec,cp2+1,end - cp2);
7095         return 1;
7096       }
7097     }
7098     /* First off, back up over constant elements at end of path */
7099     if (dirs) {
7100       for (front = end ; front >= base; front--)
7101          if (*front == '/' && !dirs--) { front++; break; }
7102     }
7103     if (!decc_efs_case_preserve) {
7104       for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
7105          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
7106     }
7107     if (cp1 != '\0') return 0;  /* Path too long. */
7108     lcend = cp2;
7109     *cp2 = '\0';  /* Pick up with memcpy later */
7110     lcfront = lcres + (front - base);
7111     /* Now skip over each ellipsis and try to match the path in front of it. */
7112     while (ells--) {
7113       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7114         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
7115             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
7116       if (cp1 < template) break; /* template started with an ellipsis */
7117       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7118         ellipsis = cp1; continue;
7119       }
7120       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7121       nextell = cp1;
7122       for (segdirs = 0, cp2 = tpl;
7123            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
7124            cp1++, cp2++) {
7125          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7126          else {
7127             if (!decc_efs_case_preserve) {
7128               *cp2 = _tolower(*cp1);  /* else lowercase for match */
7129             }
7130             else {
7131               *cp2 = *cp1;  /* else preserve case for match */
7132             }
7133          }
7134          if (*cp2 == '/') segdirs++;
7135       }
7136       if (cp1 != ellipsis - 1) return 0; /* Path too long */
7137       /* Back up at least as many dirs as in template before matching */
7138       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7139         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7140       for (match = 0; cp1 > lcres;) {
7141         resdsc.dsc$a_pointer = cp1;
7142         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7143           match++;
7144           if (match == 1) lcfront = cp1;
7145         }
7146         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7147       }
7148       if (!match) return 0;  /* Can't find prefix ??? */
7149       if (match > 1 && opts & 1) {
7150         /* This ... wildcard could cover more than one set of dirs (i.e.
7151          * a set of similar dir names is repeated).  If the template
7152          * contains more than 1 ..., upstream elements could resolve the
7153          * ambiguity, but it's not worth a full backtracking setup here.
7154          * As a quick heuristic, clip off the current default directory
7155          * if it's present to find the trimmed spec, else use the
7156          * shortest string that this ... could cover.
7157          */
7158         char def[NAM$C_MAXRSS+1], *st;
7159
7160         if (getcwd(def, sizeof def,0) == NULL) return 0;
7161         if (!decc_efs_case_preserve) {
7162           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7163             if (_tolower(*cp1) != _tolower(*cp2)) break;
7164         }
7165         segdirs = dirs - totells;  /* Min # of dirs we must have left */
7166         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7167         if (*cp1 == '\0' && *cp2 == '/') {
7168           memmove(fspec,cp2+1,end - cp2);
7169           return 1;
7170         }
7171         /* Nope -- stick with lcfront from above and keep going. */
7172       }
7173     }
7174     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7175     return 1;
7176     ellipsis = nextell;
7177   }
7178
7179 }  /* end of trim_unixpath() */
7180 /*}}}*/
7181
7182
7183 /*
7184  *  VMS readdir() routines.
7185  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7186  *
7187  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
7188  *  Minor modifications to original routines.
7189  */
7190
7191 /* readdir may have been redefined by reentr.h, so make sure we get
7192  * the local version for what we do here.
7193  */
7194 #ifdef readdir
7195 # undef readdir
7196 #endif
7197 #if !defined(PERL_IMPLICIT_CONTEXT)
7198 # define readdir Perl_readdir
7199 #else
7200 # define readdir(a) Perl_readdir(aTHX_ a)
7201 #endif
7202
7203     /* Number of elements in vms_versions array */
7204 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
7205
7206 /*
7207  *  Open a directory, return a handle for later use.
7208  */
7209 /*{{{ DIR *opendir(char*name) */
7210 MY_DIR *
7211 Perl_opendir(pTHX_ const char *name)
7212 {
7213     MY_DIR *dd;
7214     char dir[NAM$C_MAXRSS+1];
7215     Stat_t sb;
7216
7217     if (do_tovmspath(name,dir,0) == NULL) {
7218       return NULL;
7219     }
7220     /* Check access before stat; otherwise stat does not
7221      * accurately report whether it's a directory.
7222      */
7223     if (!cando_by_name(S_IRUSR,0,dir)) {
7224       /* cando_by_name has already set errno */
7225       return NULL;
7226     }
7227     if (flex_stat(dir,&sb) == -1) return NULL;
7228     if (!S_ISDIR(sb.st_mode)) {
7229       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
7230       return NULL;
7231     }
7232     /* Get memory for the handle, and the pattern. */
7233     Newx(dd,1,MY_DIR);
7234     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7235
7236     /* Fill in the fields; mainly playing with the descriptor. */
7237     sprintf(dd->pattern, "%s*.*",dir);
7238     dd->context = 0;
7239     dd->count = 0;
7240     dd->vms_wantversions = 0;
7241     dd->pat.dsc$a_pointer = dd->pattern;
7242     dd->pat.dsc$w_length = strlen(dd->pattern);
7243     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7244     dd->pat.dsc$b_class = DSC$K_CLASS_S;
7245 #if defined(USE_ITHREADS)
7246     Newx(dd->mutex,1,perl_mutex);
7247     MUTEX_INIT( (perl_mutex *) dd->mutex );
7248 #else
7249     dd->mutex = NULL;
7250 #endif
7251
7252     return dd;
7253 }  /* end of opendir() */
7254 /*}}}*/
7255
7256 /*
7257  *  Set the flag to indicate we want versions or not.
7258  */
7259 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7260 void
7261 vmsreaddirversions(MY_DIR *dd, int flag)
7262 {
7263     dd->vms_wantversions = flag;
7264 }
7265 /*}}}*/
7266
7267 /*
7268  *  Free up an opened directory.
7269  */
7270 /*{{{ void closedir(DIR *dd)*/
7271 void
7272 Perl_closedir(MY_DIR *dd)
7273 {
7274     int sts;
7275
7276     sts = lib$find_file_end(&dd->context);
7277     Safefree(dd->pattern);
7278 #if defined(USE_ITHREADS)
7279     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7280     Safefree(dd->mutex);
7281 #endif
7282     Safefree(dd);
7283 }
7284 /*}}}*/
7285
7286 /*
7287  *  Collect all the version numbers for the current file.
7288  */
7289 static void
7290 collectversions(pTHX_ MY_DIR *dd)
7291 {
7292     struct dsc$descriptor_s     pat;
7293     struct dsc$descriptor_s     res;
7294     struct my_dirent *e;
7295     char *p, *text, buff[sizeof dd->entry.d_name];
7296     int i;
7297     unsigned long context, tmpsts;
7298
7299     /* Convenient shorthand. */
7300     e = &dd->entry;
7301
7302     /* Add the version wildcard, ignoring the "*.*" put on before */
7303     i = strlen(dd->pattern);
7304     Newx(text,i + e->d_namlen + 3,char);
7305     strcpy(text, dd->pattern);
7306     sprintf(&text[i - 3], "%s;*", e->d_name);
7307
7308     /* Set up the pattern descriptor. */
7309     pat.dsc$a_pointer = text;
7310     pat.dsc$w_length = i + e->d_namlen - 1;
7311     pat.dsc$b_dtype = DSC$K_DTYPE_T;
7312     pat.dsc$b_class = DSC$K_CLASS_S;
7313
7314     /* Set up result descriptor. */
7315     res.dsc$a_pointer = buff;
7316     res.dsc$w_length = sizeof buff - 2;
7317     res.dsc$b_dtype = DSC$K_DTYPE_T;
7318     res.dsc$b_class = DSC$K_CLASS_S;
7319
7320     /* Read files, collecting versions. */
7321     for (context = 0, e->vms_verscount = 0;
7322          e->vms_verscount < VERSIZE(e);
7323          e->vms_verscount++) {
7324         tmpsts = lib$find_file(&pat, &res, &context);
7325         if (tmpsts == RMS$_NMF || context == 0) break;
7326         _ckvmssts(tmpsts);
7327         buff[sizeof buff - 1] = '\0';
7328         if ((p = strchr(buff, ';')))
7329             e->vms_versions[e->vms_verscount] = atoi(p + 1);
7330         else
7331             e->vms_versions[e->vms_verscount] = -1;
7332     }
7333
7334     _ckvmssts(lib$find_file_end(&context));
7335     Safefree(text);
7336
7337 }  /* end of collectversions() */
7338
7339 /*
7340  *  Read the next entry from the directory.
7341  */
7342 /*{{{ struct dirent *readdir(DIR *dd)*/
7343 struct my_dirent *
7344 Perl_readdir(pTHX_ MY_DIR *dd)
7345 {
7346     struct dsc$descriptor_s     res;
7347     char *p, buff[sizeof dd->entry.d_name];
7348     unsigned long int tmpsts;
7349
7350     /* Set up result descriptor, and get next file. */
7351     res.dsc$a_pointer = buff;
7352     res.dsc$w_length = sizeof buff - 2;
7353     res.dsc$b_dtype = DSC$K_DTYPE_T;
7354     res.dsc$b_class = DSC$K_CLASS_S;
7355     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
7356     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
7357     if (!(tmpsts & 1)) {
7358       set_vaxc_errno(tmpsts);
7359       switch (tmpsts) {
7360         case RMS$_PRV:
7361           set_errno(EACCES); break;
7362         case RMS$_DEV:
7363           set_errno(ENODEV); break;
7364         case RMS$_DIR:
7365           set_errno(ENOTDIR); break;
7366         case RMS$_FNF: case RMS$_DNF:
7367           set_errno(ENOENT); break;
7368         default:
7369           set_errno(EVMSERR);
7370       }
7371       return NULL;
7372     }
7373     dd->count++;
7374     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
7375     if (!decc_efs_case_preserve) {
7376       buff[sizeof buff - 1] = '\0';
7377       for (p = buff; *p; p++) *p = _tolower(*p);
7378       while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7379       *p = '\0';
7380     }
7381     else {
7382       /* we don't want to force to lowercase, just null terminate */
7383       buff[res.dsc$w_length] = '\0';
7384     }
7385     for (p = buff; *p; p++) *p = _tolower(*p);
7386     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
7387     *p = '\0';
7388
7389     /* Skip any directory component and just copy the name. */
7390     if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1);
7391     else strcpy(dd->entry.d_name, buff);
7392
7393     /* Clobber the version. */
7394     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
7395
7396     dd->entry.d_namlen = strlen(dd->entry.d_name);
7397     dd->entry.vms_verscount = 0;
7398     if (dd->vms_wantversions) collectversions(aTHX_ dd);
7399     return &dd->entry;
7400
7401 }  /* end of readdir() */
7402 /*}}}*/
7403
7404 /*
7405  *  Read the next entry from the directory -- thread-safe version.
7406  */
7407 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
7408 int
7409 Perl_readdir_r(pTHX_ MY_DIR *dd, struct my_dirent *entry, struct my_dirent **result)
7410 {
7411     int retval;
7412
7413     MUTEX_LOCK( (perl_mutex *) dd->mutex );
7414
7415     entry = readdir(dd);
7416     *result = entry;
7417     retval = ( *result == NULL ? errno : 0 );
7418
7419     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
7420
7421     return retval;
7422
7423 }  /* end of readdir_r() */
7424 /*}}}*/
7425
7426 /*
7427  *  Return something that can be used in a seekdir later.
7428  */
7429 /*{{{ long telldir(DIR *dd)*/
7430 long
7431 Perl_telldir(MY_DIR *dd)
7432 {
7433     return dd->count;
7434 }
7435 /*}}}*/
7436
7437 /*
7438  *  Return to a spot where we used to be.  Brute force.
7439  */
7440 /*{{{ void seekdir(DIR *dd,long count)*/
7441 void
7442 Perl_seekdir(pTHX_ MY_DIR *dd, long count)
7443 {
7444     int vms_wantversions;
7445
7446     /* If we haven't done anything yet... */
7447     if (dd->count == 0)
7448         return;
7449
7450     /* Remember some state, and clear it. */
7451     vms_wantversions = dd->vms_wantversions;
7452     dd->vms_wantversions = 0;
7453     _ckvmssts(lib$find_file_end(&dd->context));
7454     dd->context = 0;
7455
7456     /* The increment is in readdir(). */
7457     for (dd->count = 0; dd->count < count; )
7458         readdir(dd);
7459
7460     dd->vms_wantversions = vms_wantversions;
7461
7462 }  /* end of seekdir() */
7463 /*}}}*/
7464
7465 /* VMS subprocess management
7466  *
7467  * my_vfork() - just a vfork(), after setting a flag to record that
7468  * the current script is trying a Unix-style fork/exec.
7469  *
7470  * vms_do_aexec() and vms_do_exec() are called in response to the
7471  * perl 'exec' function.  If this follows a vfork call, then they
7472  * call out the regular perl routines in doio.c which do an
7473  * execvp (for those who really want to try this under VMS).
7474  * Otherwise, they do exactly what the perl docs say exec should
7475  * do - terminate the current script and invoke a new command
7476  * (See below for notes on command syntax.)
7477  *
7478  * do_aspawn() and do_spawn() implement the VMS side of the perl
7479  * 'system' function.
7480  *
7481  * Note on command arguments to perl 'exec' and 'system': When handled
7482  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
7483  * are concatenated to form a DCL command string.  If the first arg
7484  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
7485  * the command string is handed off to DCL directly.  Otherwise,
7486  * the first token of the command is taken as the filespec of an image
7487  * to run.  The filespec is expanded using a default type of '.EXE' and
7488  * the process defaults for device, directory, etc., and if found, the resultant
7489  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
7490  * the command string as parameters.  This is perhaps a bit complicated,
7491  * but I hope it will form a happy medium between what VMS folks expect
7492  * from lib$spawn and what Unix folks expect from exec.
7493  */
7494
7495 static int vfork_called;
7496
7497 /*{{{int my_vfork()*/
7498 int
7499 my_vfork()
7500 {
7501   vfork_called++;
7502   return vfork();
7503 }
7504 /*}}}*/
7505
7506
7507 static void
7508 vms_execfree(struct dsc$descriptor_s *vmscmd)
7509 {
7510   if (vmscmd) {
7511       if (vmscmd->dsc$a_pointer) {
7512           Safefree(vmscmd->dsc$a_pointer);
7513       }
7514       Safefree(vmscmd);
7515   }
7516 }
7517
7518 static char *
7519 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
7520 {
7521   char *junk, *tmps = Nullch;
7522   register size_t cmdlen = 0;
7523   size_t rlen;
7524   register SV **idx;
7525   STRLEN n_a;
7526
7527   idx = mark;
7528   if (really) {
7529     tmps = SvPV(really,rlen);
7530     if (*tmps) {
7531       cmdlen += rlen + 1;
7532       idx++;
7533     }
7534   }
7535
7536   for (idx++; idx <= sp; idx++) {
7537     if (*idx) {
7538       junk = SvPVx(*idx,rlen);
7539       cmdlen += rlen ? rlen + 1 : 0;
7540     }
7541   }
7542   Newx(PL_Cmd,cmdlen+1,char);
7543
7544   if (tmps && *tmps) {
7545     strcpy(PL_Cmd,tmps);
7546     mark++;
7547   }
7548   else *PL_Cmd = '\0';
7549   while (++mark <= sp) {
7550     if (*mark) {
7551       char *s = SvPVx(*mark,n_a);
7552       if (!*s) continue;
7553       if (*PL_Cmd) strcat(PL_Cmd," ");
7554       strcat(PL_Cmd,s);
7555     }
7556   }
7557   return PL_Cmd;
7558
7559 }  /* end of setup_argstr() */
7560
7561
7562 static unsigned long int
7563 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
7564                    struct dsc$descriptor_s **pvmscmd)
7565 {
7566   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
7567   char image_name[NAM$C_MAXRSS+1];
7568   char image_argv[NAM$C_MAXRSS+1];
7569   $DESCRIPTOR(defdsc,".EXE");
7570   $DESCRIPTOR(defdsc2,".");
7571   $DESCRIPTOR(resdsc,resspec);
7572   struct dsc$descriptor_s *vmscmd;
7573   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7574   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
7575   register char *s, *rest, *cp, *wordbreak;
7576   char * cmd;
7577   int cmdlen;
7578   register int isdcl;
7579
7580   Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
7581
7582   /* Make a copy for modification */
7583   cmdlen = strlen(incmd);
7584   Newx(cmd, cmdlen+1, char);
7585   strncpy(cmd, incmd, cmdlen);
7586   cmd[cmdlen] = 0;
7587   image_name[0] = 0;
7588   image_argv[0] = 0;
7589
7590   vmscmd->dsc$a_pointer = NULL;
7591   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
7592   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
7593   vmscmd->dsc$w_length = 0;
7594   if (pvmscmd) *pvmscmd = vmscmd;
7595
7596   if (suggest_quote) *suggest_quote = 0;
7597
7598   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
7599     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
7600     Safefree(cmd);
7601   }
7602
7603   s = cmd;
7604
7605   while (*s && isspace(*s)) s++;
7606
7607   if (*s == '@' || *s == '$') {
7608     vmsspec[0] = *s;  rest = s + 1;
7609     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
7610   }
7611   else { cp = vmsspec; rest = s; }
7612   if (*rest == '.' || *rest == '/') {
7613     char *cp2;
7614     for (cp2 = resspec;
7615          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
7616          rest++, cp2++) *cp2 = *rest;
7617     *cp2 = '\0';
7618     if (do_tovmsspec(resspec,cp,0)) {
7619       s = vmsspec;
7620       if (*rest) {
7621         for (cp2 = vmsspec + strlen(vmsspec);
7622              *rest && cp2 - vmsspec < sizeof vmsspec;
7623              rest++, cp2++) *cp2 = *rest;
7624         *cp2 = '\0';
7625       }
7626     }
7627   }
7628   /* Intuit whether verb (first word of cmd) is a DCL command:
7629    *   - if first nonspace char is '@', it's a DCL indirection
7630    * otherwise
7631    *   - if verb contains a filespec separator, it's not a DCL command
7632    *   - if it doesn't, caller tells us whether to default to a DCL
7633    *     command, or to a local image unless told it's DCL (by leading '$')
7634    */
7635   if (*s == '@') {
7636       isdcl = 1;
7637       if (suggest_quote) *suggest_quote = 1;
7638   } else {
7639     register char *filespec = strpbrk(s,":<[.;");
7640     rest = wordbreak = strpbrk(s," \"\t/");
7641     if (!wordbreak) wordbreak = s + strlen(s);
7642     if (*s == '$') check_img = 0;
7643     if (filespec && (filespec < wordbreak)) isdcl = 0;
7644     else isdcl = !check_img;
7645   }
7646
7647   if (!isdcl) {
7648     imgdsc.dsc$a_pointer = s;
7649     imgdsc.dsc$w_length = wordbreak - s;
7650     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7651     if (!(retsts&1)) {
7652         _ckvmssts(lib$find_file_end(&cxt));
7653         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7654       if (!(retsts & 1) && *s == '$') {
7655         _ckvmssts(lib$find_file_end(&cxt));
7656         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
7657         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7658         if (!(retsts&1)) {
7659           _ckvmssts(lib$find_file_end(&cxt));
7660           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7661         }
7662       }
7663     }
7664     _ckvmssts(lib$find_file_end(&cxt));
7665
7666     if (retsts & 1) {
7667       FILE *fp;
7668       s = resspec;
7669       while (*s && !isspace(*s)) s++;
7670       *s = '\0';
7671
7672       /* check that it's really not DCL with no file extension */
7673       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
7674       if (fp) {
7675         char b[256] = {0,0,0,0};
7676         read(fileno(fp), b, 256);
7677         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
7678         if (isdcl) {
7679           int shebang_len;
7680
7681           /* Check for script */
7682           shebang_len = 0;
7683           if ((b[0] == '#') && (b[1] == '!'))
7684              shebang_len = 2;
7685 #ifdef ALTERNATE_SHEBANG
7686           else {
7687             shebang_len = strlen(ALTERNATE_SHEBANG);
7688             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
7689               char * perlstr;
7690                 perlstr = strstr("perl",b);
7691                 if (perlstr == NULL)
7692                   shebang_len = 0;
7693             }
7694             else
7695               shebang_len = 0;
7696           }
7697 #endif
7698
7699           if (shebang_len > 0) {
7700           int i;
7701           int j;
7702           char tmpspec[NAM$C_MAXRSS + 1];
7703
7704             i = shebang_len;
7705              /* Image is following after white space */
7706             /*--------------------------------------*/
7707             while (isprint(b[i]) && isspace(b[i]))
7708                 i++;
7709
7710             j = 0;
7711             while (isprint(b[i]) && !isspace(b[i])) {
7712                 tmpspec[j++] = b[i++];
7713                 if (j >= NAM$C_MAXRSS)
7714                    break;
7715             }
7716             tmpspec[j] = '\0';
7717
7718              /* There may be some default parameters to the image */
7719             /*---------------------------------------------------*/
7720             j = 0;
7721             while (isprint(b[i])) {
7722                 image_argv[j++] = b[i++];
7723                 if (j >= NAM$C_MAXRSS)
7724                    break;
7725             }
7726             while ((j > 0) && !isprint(image_argv[j-1]))
7727                 j--;
7728             image_argv[j] = 0;
7729
7730             /* It will need to be converted to VMS format and validated */
7731             if (tmpspec[0] != '\0') {
7732               char * iname;
7733
7734                /* Try to find the exact program requested to be run */
7735               /*---------------------------------------------------*/
7736               iname = do_rmsexpand
7737                   (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
7738               if (iname != NULL) {
7739                 if (cando_by_name(S_IXUSR,0,image_name)) {
7740                   /* MCR prefix needed */
7741                   isdcl = 0;
7742                 }
7743                 else {
7744                    /* Try again with a null type */
7745                   /*----------------------------*/
7746                   iname = do_rmsexpand
7747                     (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
7748                   if (iname != NULL) {
7749                     if (cando_by_name(S_IXUSR,0,image_name)) {
7750                       /* MCR prefix needed */
7751                       isdcl = 0;
7752                     }
7753                   }
7754                 }
7755
7756                  /* Did we find the image to run the script? */
7757                 /*------------------------------------------*/
7758                 if (isdcl) {
7759                   char *tchr;
7760
7761                    /* Assume DCL or foreign command exists */
7762                   /*--------------------------------------*/
7763                   tchr = strrchr(tmpspec, '/');
7764                   if (tchr != NULL) {
7765                     tchr++;
7766                   }
7767                   else {
7768                     tchr = tmpspec;
7769                   }
7770                   strcpy(image_name, tchr);
7771                 }
7772               }
7773             }
7774           }
7775         }
7776         fclose(fp);
7777       }
7778       if (check_img && isdcl) return RMS$_FNF;
7779
7780       if (cando_by_name(S_IXUSR,0,resspec)) {
7781         Newx(vmscmd->dsc$a_pointer, MAX_DCL_LINE_LENGTH ,char);
7782         if (!isdcl) {
7783             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
7784             if (image_name[0] != 0) {
7785                 strcat(vmscmd->dsc$a_pointer, image_name);
7786                 strcat(vmscmd->dsc$a_pointer, " ");
7787             }
7788         } else if (image_name[0] != 0) {
7789             strcpy(vmscmd->dsc$a_pointer, image_name);
7790             strcat(vmscmd->dsc$a_pointer, " ");
7791         } else {
7792             strcpy(vmscmd->dsc$a_pointer,"@");
7793         }
7794         if (suggest_quote) *suggest_quote = 1;
7795
7796         /* If there is an image name, use original command */
7797         if (image_name[0] == 0)
7798             strcat(vmscmd->dsc$a_pointer,resspec);
7799         else {
7800             rest = cmd;
7801             while (*rest && isspace(*rest)) rest++;
7802         }
7803
7804         if (image_argv[0] != 0) {
7805           strcat(vmscmd->dsc$a_pointer,image_argv);
7806           strcat(vmscmd->dsc$a_pointer, " ");
7807         }
7808         if (rest) {
7809            int rest_len;
7810            int vmscmd_len;
7811
7812            rest_len = strlen(rest);
7813            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
7814            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
7815               strcat(vmscmd->dsc$a_pointer,rest);
7816            else
7817              retsts = CLI$_BUFOVF;
7818         }
7819         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
7820         Safefree(cmd);
7821         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
7822       }
7823       else retsts = RMS$_PRV;
7824     }
7825   }
7826   /* It's either a DCL command or we couldn't find a suitable image */
7827   vmscmd->dsc$w_length = strlen(cmd);
7828 /*  if (cmd == PL_Cmd) {
7829       vmscmd->dsc$a_pointer = PL_Cmd;
7830       if (suggest_quote) *suggest_quote = 1;
7831   }
7832   else  */
7833       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
7834
7835   Safefree(cmd);
7836
7837   /* check if it's a symbol (for quoting purposes) */
7838   if (suggest_quote && !*suggest_quote) {
7839     int iss;
7840     char equiv[LNM$C_NAMLENGTH];
7841     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7842     eqvdsc.dsc$a_pointer = equiv;
7843
7844     iss = lib$get_symbol(vmscmd,&eqvdsc);
7845     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
7846   }
7847   if (!(retsts & 1)) {
7848     /* just hand off status values likely to be due to user error */
7849     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
7850         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
7851        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
7852     else { _ckvmssts(retsts); }
7853   }
7854
7855   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
7856
7857 }  /* end of setup_cmddsc() */
7858
7859
7860 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
7861 bool
7862 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
7863 {
7864   if (sp > mark) {
7865     if (vfork_called) {           /* this follows a vfork - act Unixish */
7866       vfork_called--;
7867       if (vfork_called < 0) {
7868         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
7869         vfork_called = 0;
7870       }
7871       else return do_aexec(really,mark,sp);
7872     }
7873                                            /* no vfork - act VMSish */
7874     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
7875
7876   }
7877
7878   return FALSE;
7879 }  /* end of vms_do_aexec() */
7880 /*}}}*/
7881
7882 /* {{{bool vms_do_exec(char *cmd) */
7883 bool
7884 Perl_vms_do_exec(pTHX_ const char *cmd)
7885 {
7886   struct dsc$descriptor_s *vmscmd;
7887
7888   if (vfork_called) {             /* this follows a vfork - act Unixish */
7889     vfork_called--;
7890     if (vfork_called < 0) {
7891       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
7892       vfork_called = 0;
7893     }
7894     else return do_exec(cmd);
7895   }
7896
7897   {                               /* no vfork - act VMSish */
7898     unsigned long int retsts;
7899
7900     TAINT_ENV();
7901     TAINT_PROPER("exec");
7902     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
7903       retsts = lib$do_command(vmscmd);
7904
7905     switch (retsts) {
7906       case RMS$_FNF: case RMS$_DNF:
7907         set_errno(ENOENT); break;
7908       case RMS$_DIR:
7909         set_errno(ENOTDIR); break;
7910       case RMS$_DEV:
7911         set_errno(ENODEV); break;
7912       case RMS$_PRV:
7913         set_errno(EACCES); break;
7914       case RMS$_SYN:
7915         set_errno(EINVAL); break;
7916       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
7917         set_errno(E2BIG); break;
7918       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
7919         _ckvmssts(retsts); /* fall through */
7920       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
7921         set_errno(EVMSERR);
7922     }
7923     set_vaxc_errno(retsts);
7924     if (ckWARN(WARN_EXEC)) {
7925       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
7926              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
7927     }
7928     vms_execfree(vmscmd);
7929   }
7930
7931   return FALSE;
7932
7933 }  /* end of vms_do_exec() */
7934 /*}}}*/
7935
7936 unsigned long int Perl_do_spawn(pTHX_ const char *);
7937
7938 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
7939 unsigned long int
7940 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
7941 {
7942   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
7943
7944   return SS$_ABORT;
7945 }  /* end of do_aspawn() */
7946 /*}}}*/
7947
7948 /* {{{unsigned long int do_spawn(char *cmd) */
7949 unsigned long int
7950 Perl_do_spawn(pTHX_ const char *cmd)
7951 {
7952   unsigned long int sts, substs;
7953
7954   TAINT_ENV();
7955   TAINT_PROPER("spawn");
7956   if (!cmd || !*cmd) {
7957     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
7958     if (!(sts & 1)) {
7959       switch (sts) {
7960         case RMS$_FNF:  case RMS$_DNF:
7961           set_errno(ENOENT); break;
7962         case RMS$_DIR:
7963           set_errno(ENOTDIR); break;
7964         case RMS$_DEV:
7965           set_errno(ENODEV); break;
7966         case RMS$_PRV:
7967           set_errno(EACCES); break;
7968         case RMS$_SYN:
7969           set_errno(EINVAL); break;
7970         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
7971           set_errno(E2BIG); break;
7972         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
7973           _ckvmssts(sts); /* fall through */
7974         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
7975           set_errno(EVMSERR);
7976       }
7977       set_vaxc_errno(sts);
7978       if (ckWARN(WARN_EXEC)) {
7979         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
7980                     Strerror(errno));
7981       }
7982     }
7983     sts = substs;
7984   }
7985   else {
7986     PerlIO * fp;
7987     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
7988     if (fp != NULL)
7989       my_pclose(fp);
7990   }
7991   return sts;
7992 }  /* end of do_spawn() */
7993 /*}}}*/
7994
7995
7996 static unsigned int *sockflags, sockflagsize;
7997
7998 /*
7999  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8000  * routines found in some versions of the CRTL can't deal with sockets.
8001  * We don't shim the other file open routines since a socket isn't
8002  * likely to be opened by a name.
8003  */
8004 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8005 FILE *my_fdopen(int fd, const char *mode)
8006 {
8007   FILE *fp = fdopen(fd, mode);
8008
8009   if (fp) {
8010     unsigned int fdoff = fd / sizeof(unsigned int);
8011     Stat_t sbuf; /* native stat; we don't need flex_stat */
8012     if (!sockflagsize || fdoff > sockflagsize) {
8013       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
8014       else           Newx  (sockflags,fdoff+2,unsigned int);
8015       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8016       sockflagsize = fdoff + 2;
8017     }
8018     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8019       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8020   }
8021   return fp;
8022
8023 }
8024 /*}}}*/
8025
8026
8027 /*
8028  * Clear the corresponding bit when the (possibly) socket stream is closed.
8029  * There still a small hole: we miss an implicit close which might occur
8030  * via freopen().  >> Todo
8031  */
8032 /*{{{ int my_fclose(FILE *fp)*/
8033 int my_fclose(FILE *fp) {
8034   if (fp) {
8035     unsigned int fd = fileno(fp);
8036     unsigned int fdoff = fd / sizeof(unsigned int);
8037
8038     if (sockflagsize && fdoff <= sockflagsize)
8039       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8040   }
8041   return fclose(fp);
8042 }
8043 /*}}}*/
8044
8045
8046 /*
8047  * A simple fwrite replacement which outputs itmsz*nitm chars without
8048  * introducing record boundaries every itmsz chars.
8049  * We are using fputs, which depends on a terminating null.  We may
8050  * well be writing binary data, so we need to accommodate not only
8051  * data with nulls sprinkled in the middle but also data with no null
8052  * byte at the end.
8053  */
8054 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8055 int
8056 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8057 {
8058   register char *cp, *end, *cpd, *data;
8059   register unsigned int fd = fileno(dest);
8060   register unsigned int fdoff = fd / sizeof(unsigned int);
8061   int retval;
8062   int bufsize = itmsz * nitm + 1;
8063
8064   if (fdoff < sockflagsize &&
8065       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8066     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8067     return nitm;
8068   }
8069
8070   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8071   memcpy( data, src, itmsz*nitm );
8072   data[itmsz*nitm] = '\0';
8073
8074   end = data + itmsz * nitm;
8075   retval = (int) nitm; /* on success return # items written */
8076
8077   cpd = data;
8078   while (cpd <= end) {
8079     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8080     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8081     if (cp < end)
8082       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8083     cpd = cp + 1;
8084   }
8085
8086   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8087   return retval;
8088
8089 }  /* end of my_fwrite() */
8090 /*}}}*/
8091
8092 /*{{{ int my_flush(FILE *fp)*/
8093 int
8094 Perl_my_flush(pTHX_ FILE *fp)
8095 {
8096     int res;
8097     if ((res = fflush(fp)) == 0 && fp) {
8098 #ifdef VMS_DO_SOCKETS
8099         Stat_t s;
8100         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8101 #endif
8102             res = fsync(fileno(fp));
8103     }
8104 /*
8105  * If the flush succeeded but set end-of-file, we need to clear
8106  * the error because our caller may check ferror().  BTW, this
8107  * probably means we just flushed an empty file.
8108  */
8109     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8110
8111     return res;
8112 }
8113 /*}}}*/
8114
8115 /*
8116  * Here are replacements for the following Unix routines in the VMS environment:
8117  *      getpwuid    Get information for a particular UIC or UID
8118  *      getpwnam    Get information for a named user
8119  *      getpwent    Get information for each user in the rights database
8120  *      setpwent    Reset search to the start of the rights database
8121  *      endpwent    Finish searching for users in the rights database
8122  *
8123  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8124  * (defined in pwd.h), which contains the following fields:-
8125  *      struct passwd {
8126  *              char        *pw_name;    Username (in lower case)
8127  *              char        *pw_passwd;  Hashed password
8128  *              unsigned int pw_uid;     UIC
8129  *              unsigned int pw_gid;     UIC group  number
8130  *              char        *pw_unixdir; Default device/directory (VMS-style)
8131  *              char        *pw_gecos;   Owner name
8132  *              char        *pw_dir;     Default device/directory (Unix-style)
8133  *              char        *pw_shell;   Default CLI name (eg. DCL)
8134  *      };
8135  * If the specified user does not exist, getpwuid and getpwnam return NULL.
8136  *
8137  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8138  * not the UIC member number (eg. what's returned by getuid()),
8139  * getpwuid() can accept either as input (if uid is specified, the caller's
8140  * UIC group is used), though it won't recognise gid=0.
8141  *
8142  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8143  * information about other users in your group or in other groups, respectively.
8144  * If the required privilege is not available, then these routines fill only
8145  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8146  * string).
8147  *
8148  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8149  */
8150
8151 /* sizes of various UAF record fields */
8152 #define UAI$S_USERNAME 12
8153 #define UAI$S_IDENT    31
8154 #define UAI$S_OWNER    31
8155 #define UAI$S_DEFDEV   31
8156 #define UAI$S_DEFDIR   63
8157 #define UAI$S_DEFCLI   31
8158 #define UAI$S_PWD       8
8159
8160 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
8161                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8162                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
8163
8164 static char __empty[]= "";
8165 static struct passwd __passwd_empty=
8166     {(char *) __empty, (char *) __empty, 0, 0,
8167      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8168 static int contxt= 0;
8169 static struct passwd __pwdcache;
8170 static char __pw_namecache[UAI$S_IDENT+1];
8171
8172 /*
8173  * This routine does most of the work extracting the user information.
8174  */
8175 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8176 {
8177     static struct {
8178         unsigned char length;
8179         char pw_gecos[UAI$S_OWNER+1];
8180     } owner;
8181     static union uicdef uic;
8182     static struct {
8183         unsigned char length;
8184         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8185     } defdev;
8186     static struct {
8187         unsigned char length;
8188         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8189     } defdir;
8190     static struct {
8191         unsigned char length;
8192         char pw_shell[UAI$S_DEFCLI+1];
8193     } defcli;
8194     static char pw_passwd[UAI$S_PWD+1];
8195
8196     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8197     struct dsc$descriptor_s name_desc;
8198     unsigned long int sts;
8199
8200     static struct itmlst_3 itmlst[]= {
8201         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
8202         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
8203         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
8204         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
8205         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
8206         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
8207         {0,                0,           NULL,    NULL}};
8208
8209     name_desc.dsc$w_length=  strlen(name);
8210     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8211     name_desc.dsc$b_class=   DSC$K_CLASS_S;
8212     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8213
8214 /*  Note that sys$getuai returns many fields as counted strings. */
8215     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8216     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8217       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8218     }
8219     else { _ckvmssts(sts); }
8220     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
8221
8222     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
8223     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8224     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8225     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8226     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8227     owner.pw_gecos[lowner]=            '\0';
8228     defdev.pw_dir[ldefdev+ldefdir]= '\0';
8229     defcli.pw_shell[ldefcli]=          '\0';
8230     if (valid_uic(uic)) {
8231         pwd->pw_uid= uic.uic$l_uic;
8232         pwd->pw_gid= uic.uic$v_group;
8233     }
8234     else
8235       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8236     pwd->pw_passwd=  pw_passwd;
8237     pwd->pw_gecos=   owner.pw_gecos;
8238     pwd->pw_dir=     defdev.pw_dir;
8239     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8240     pwd->pw_shell=   defcli.pw_shell;
8241     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8242         int ldir;
8243         ldir= strlen(pwd->pw_unixdir) - 1;
8244         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8245     }
8246     else
8247         strcpy(pwd->pw_unixdir, pwd->pw_dir);
8248     if (!decc_efs_case_preserve)
8249         __mystrtolower(pwd->pw_unixdir);
8250     return 1;
8251 }
8252
8253 /*
8254  * Get information for a named user.
8255 */
8256 /*{{{struct passwd *getpwnam(char *name)*/
8257 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8258 {
8259     struct dsc$descriptor_s name_desc;
8260     union uicdef uic;
8261     unsigned long int status, sts;
8262
8263     __pwdcache = __passwd_empty;
8264     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8265       /* We still may be able to determine pw_uid and pw_gid */
8266       name_desc.dsc$w_length=  strlen(name);
8267       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8268       name_desc.dsc$b_class=   DSC$K_CLASS_S;
8269       name_desc.dsc$a_pointer= (char *) name;
8270       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
8271         __pwdcache.pw_uid= uic.uic$l_uic;
8272         __pwdcache.pw_gid= uic.uic$v_group;
8273       }
8274       else {
8275         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8276           set_vaxc_errno(sts);
8277           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
8278           return NULL;
8279         }
8280         else { _ckvmssts(sts); }
8281       }
8282     }
8283     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8284     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8285     __pwdcache.pw_name= __pw_namecache;
8286     return &__pwdcache;
8287 }  /* end of my_getpwnam() */
8288 /*}}}*/
8289
8290 /*
8291  * Get information for a particular UIC or UID.
8292  * Called by my_getpwent with uid=-1 to list all users.
8293 */
8294 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
8295 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
8296 {
8297     const $DESCRIPTOR(name_desc,__pw_namecache);
8298     unsigned short lname;
8299     union uicdef uic;
8300     unsigned long int status;
8301
8302     if (uid == (unsigned int) -1) {
8303       do {
8304         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
8305         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
8306           set_vaxc_errno(status);
8307           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8308           my_endpwent();
8309           return NULL;
8310         }
8311         else { _ckvmssts(status); }
8312       } while (!valid_uic (uic));
8313     }
8314     else {
8315       uic.uic$l_uic= uid;
8316       if (!uic.uic$v_group)
8317         uic.uic$v_group= PerlProc_getgid();
8318       if (valid_uic(uic))
8319         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
8320       else status = SS$_IVIDENT;
8321       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
8322           status == RMS$_PRV) {
8323         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8324         return NULL;
8325       }
8326       else { _ckvmssts(status); }
8327     }
8328     __pw_namecache[lname]= '\0';
8329     __mystrtolower(__pw_namecache);
8330
8331     __pwdcache = __passwd_empty;
8332     __pwdcache.pw_name = __pw_namecache;
8333
8334 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
8335     The identifier's value is usually the UIC, but it doesn't have to be,
8336     so if we can, we let fillpasswd update this. */
8337     __pwdcache.pw_uid =  uic.uic$l_uic;
8338     __pwdcache.pw_gid =  uic.uic$v_group;
8339
8340     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
8341     return &__pwdcache;
8342
8343 }  /* end of my_getpwuid() */
8344 /*}}}*/
8345
8346 /*
8347  * Get information for next user.
8348 */
8349 /*{{{struct passwd *my_getpwent()*/
8350 struct passwd *Perl_my_getpwent(pTHX)
8351 {
8352     return (my_getpwuid((unsigned int) -1));
8353 }
8354 /*}}}*/
8355
8356 /*
8357  * Finish searching rights database for users.
8358 */
8359 /*{{{void my_endpwent()*/
8360 void Perl_my_endpwent(pTHX)
8361 {
8362     if (contxt) {
8363       _ckvmssts(sys$finish_rdb(&contxt));
8364       contxt= 0;
8365     }
8366 }
8367 /*}}}*/
8368
8369 #ifdef HOMEGROWN_POSIX_SIGNALS
8370   /* Signal handling routines, pulled into the core from POSIX.xs.
8371    *
8372    * We need these for threads, so they've been rolled into the core,
8373    * rather than left in POSIX.xs.
8374    *
8375    * (DRS, Oct 23, 1997)
8376    */
8377
8378   /* sigset_t is atomic under VMS, so these routines are easy */
8379 /*{{{int my_sigemptyset(sigset_t *) */
8380 int my_sigemptyset(sigset_t *set) {
8381     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8382     *set = 0; return 0;
8383 }
8384 /*}}}*/
8385
8386
8387 /*{{{int my_sigfillset(sigset_t *)*/
8388 int my_sigfillset(sigset_t *set) {
8389     int i;
8390     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8391     for (i = 0; i < NSIG; i++) *set |= (1 << i);
8392     return 0;
8393 }
8394 /*}}}*/
8395
8396
8397 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
8398 int my_sigaddset(sigset_t *set, int sig) {
8399     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8400     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8401     *set |= (1 << (sig - 1));
8402     return 0;
8403 }
8404 /*}}}*/
8405
8406
8407 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
8408 int my_sigdelset(sigset_t *set, int sig) {
8409     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8410     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8411     *set &= ~(1 << (sig - 1));
8412     return 0;
8413 }
8414 /*}}}*/
8415
8416
8417 /*{{{int my_sigismember(sigset_t *set, int sig)*/
8418 int my_sigismember(sigset_t *set, int sig) {
8419     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8420     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8421     return *set & (1 << (sig - 1));
8422 }
8423 /*}}}*/
8424
8425
8426 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
8427 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
8428     sigset_t tempmask;
8429
8430     /* If set and oset are both null, then things are badly wrong. Bail out. */
8431     if ((oset == NULL) && (set == NULL)) {
8432       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
8433       return -1;
8434     }
8435
8436     /* If set's null, then we're just handling a fetch. */
8437     if (set == NULL) {
8438         tempmask = sigblock(0);
8439     }
8440     else {
8441       switch (how) {
8442       case SIG_SETMASK:
8443         tempmask = sigsetmask(*set);
8444         break;
8445       case SIG_BLOCK:
8446         tempmask = sigblock(*set);
8447         break;
8448       case SIG_UNBLOCK:
8449         tempmask = sigblock(0);
8450         sigsetmask(*oset & ~tempmask);
8451         break;
8452       default:
8453         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8454         return -1;
8455       }
8456     }
8457
8458     /* Did they pass us an oset? If so, stick our holding mask into it */
8459     if (oset)
8460       *oset = tempmask;
8461
8462     return 0;
8463 }
8464 /*}}}*/
8465 #endif  /* HOMEGROWN_POSIX_SIGNALS */
8466
8467
8468 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
8469  * my_utime(), and flex_stat(), all of which operate on UTC unless
8470  * VMSISH_TIMES is true.
8471  */
8472 /* method used to handle UTC conversions:
8473  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
8474  */
8475 static int gmtime_emulation_type;
8476 /* number of secs to add to UTC POSIX-style time to get local time */
8477 static long int utc_offset_secs;
8478
8479 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
8480  * in vmsish.h.  #undef them here so we can call the CRTL routines
8481  * directly.
8482  */
8483 #undef gmtime
8484 #undef localtime
8485 #undef time
8486
8487
8488 /*
8489  * DEC C previous to 6.0 corrupts the behavior of the /prefix
8490  * qualifier with the extern prefix pragma.  This provisional
8491  * hack circumvents this prefix pragma problem in previous
8492  * precompilers.
8493  */
8494 #if defined(__VMS_VER) && __VMS_VER >= 70000000
8495 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
8496 #    pragma __extern_prefix save
8497 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
8498 #    define gmtime decc$__utctz_gmtime
8499 #    define localtime decc$__utctz_localtime
8500 #    define time decc$__utc_time
8501 #    pragma __extern_prefix restore
8502
8503      struct tm *gmtime(), *localtime();
8504
8505 #  endif
8506 #endif
8507
8508
8509 static time_t toutc_dst(time_t loc) {
8510   struct tm *rsltmp;
8511
8512   if ((rsltmp = localtime(&loc)) == NULL) return -1;
8513   loc -= utc_offset_secs;
8514   if (rsltmp->tm_isdst) loc -= 3600;
8515   return loc;
8516 }
8517 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
8518        ((gmtime_emulation_type || my_time(NULL)), \
8519        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
8520        ((secs) - utc_offset_secs))))
8521
8522 static time_t toloc_dst(time_t utc) {
8523   struct tm *rsltmp;
8524
8525   utc += utc_offset_secs;
8526   if ((rsltmp = localtime(&utc)) == NULL) return -1;
8527   if (rsltmp->tm_isdst) utc += 3600;
8528   return utc;
8529 }
8530 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
8531        ((gmtime_emulation_type || my_time(NULL)), \
8532        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
8533        ((secs) + utc_offset_secs))))
8534
8535 #ifndef RTL_USES_UTC
8536 /*
8537
8538     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
8539         DST starts on 1st sun of april      at 02:00  std time
8540             ends on last sun of october     at 02:00  dst time
8541     see the UCX management command reference, SET CONFIG TIMEZONE
8542     for formatting info.
8543
8544     No, it's not as general as it should be, but then again, NOTHING
8545     will handle UK times in a sensible way.
8546 */
8547
8548
8549 /*
8550     parse the DST start/end info:
8551     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
8552 */
8553
8554 static char *
8555 tz_parse_startend(char *s, struct tm *w, int *past)
8556 {
8557     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
8558     int ly, dozjd, d, m, n, hour, min, sec, j, k;
8559     time_t g;
8560
8561     if (!s)    return 0;
8562     if (!w) return 0;
8563     if (!past) return 0;
8564
8565     ly = 0;
8566     if (w->tm_year % 4        == 0) ly = 1;
8567     if (w->tm_year % 100      == 0) ly = 0;
8568     if (w->tm_year+1900 % 400 == 0) ly = 1;
8569     if (ly) dinm[1]++;
8570
8571     dozjd = isdigit(*s);
8572     if (*s == 'J' || *s == 'j' || dozjd) {
8573         if (!dozjd && !isdigit(*++s)) return 0;
8574         d = *s++ - '0';
8575         if (isdigit(*s)) {
8576             d = d*10 + *s++ - '0';
8577             if (isdigit(*s)) {
8578                 d = d*10 + *s++ - '0';
8579             }
8580         }
8581         if (d == 0) return 0;
8582         if (d > 366) return 0;
8583         d--;
8584         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
8585         g = d * 86400;
8586         dozjd = 1;
8587     } else if (*s == 'M' || *s == 'm') {
8588         if (!isdigit(*++s)) return 0;
8589         m = *s++ - '0';
8590         if (isdigit(*s)) m = 10*m + *s++ - '0';
8591         if (*s != '.') return 0;
8592         if (!isdigit(*++s)) return 0;
8593         n = *s++ - '0';
8594         if (n < 1 || n > 5) return 0;
8595         if (*s != '.') return 0;
8596         if (!isdigit(*++s)) return 0;
8597         d = *s++ - '0';
8598         if (d > 6) return 0;
8599     }
8600
8601     if (*s == '/') {
8602         if (!isdigit(*++s)) return 0;
8603         hour = *s++ - '0';
8604         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
8605         if (*s == ':') {
8606             if (!isdigit(*++s)) return 0;
8607             min = *s++ - '0';
8608             if (isdigit(*s)) min = 10*min + *s++ - '0';
8609             if (*s == ':') {
8610                 if (!isdigit(*++s)) return 0;
8611                 sec = *s++ - '0';
8612                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
8613             }
8614         }
8615     } else {
8616         hour = 2;
8617         min = 0;
8618         sec = 0;
8619     }
8620
8621     if (dozjd) {
8622         if (w->tm_yday < d) goto before;
8623         if (w->tm_yday > d) goto after;
8624     } else {
8625         if (w->tm_mon+1 < m) goto before;
8626         if (w->tm_mon+1 > m) goto after;
8627
8628         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
8629         k = d - j; /* mday of first d */
8630         if (k <= 0) k += 7;
8631         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
8632         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
8633         if (w->tm_mday < k) goto before;
8634         if (w->tm_mday > k) goto after;
8635     }
8636
8637     if (w->tm_hour < hour) goto before;
8638     if (w->tm_hour > hour) goto after;
8639     if (w->tm_min  < min)  goto before;
8640     if (w->tm_min  > min)  goto after;
8641     if (w->tm_sec  < sec)  goto before;
8642     goto after;
8643
8644 before:
8645     *past = 0;
8646     return s;
8647 after:
8648     *past = 1;
8649     return s;
8650 }
8651
8652
8653
8654
8655 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
8656
8657 static char *
8658 tz_parse_offset(char *s, int *offset)
8659 {
8660     int hour = 0, min = 0, sec = 0;
8661     int neg = 0;
8662     if (!s) return 0;
8663     if (!offset) return 0;
8664
8665     if (*s == '-') {neg++; s++;}
8666     if (*s == '+') s++;
8667     if (!isdigit(*s)) return 0;
8668     hour = *s++ - '0';
8669     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
8670     if (hour > 24) return 0;
8671     if (*s == ':') {
8672         if (!isdigit(*++s)) return 0;
8673         min = *s++ - '0';
8674         if (isdigit(*s)) min = min*10 + (*s++ - '0');
8675         if (min > 59) return 0;
8676         if (*s == ':') {
8677             if (!isdigit(*++s)) return 0;
8678             sec = *s++ - '0';
8679             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
8680             if (sec > 59) return 0;
8681         }
8682     }
8683
8684     *offset = (hour*60+min)*60 + sec;
8685     if (neg) *offset = -*offset;
8686     return s;
8687 }
8688
8689 /*
8690     input time is w, whatever type of time the CRTL localtime() uses.
8691     sets dst, the zone, and the gmtoff (seconds)
8692
8693     caches the value of TZ and UCX$TZ env variables; note that
8694     my_setenv looks for these and sets a flag if they're changed
8695     for efficiency.
8696
8697     We have to watch out for the "australian" case (dst starts in
8698     october, ends in april)...flagged by "reverse" and checked by
8699     scanning through the months of the previous year.
8700
8701 */
8702
8703 static int
8704 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
8705 {
8706     time_t when;
8707     struct tm *w2;
8708     char *s,*s2;
8709     char *dstzone, *tz, *s_start, *s_end;
8710     int std_off, dst_off, isdst;
8711     int y, dststart, dstend;
8712     static char envtz[1025];  /* longer than any logical, symbol, ... */
8713     static char ucxtz[1025];
8714     static char reversed = 0;
8715
8716     if (!w) return 0;
8717
8718     if (tz_updated) {
8719         tz_updated = 0;
8720         reversed = -1;  /* flag need to check  */
8721         envtz[0] = ucxtz[0] = '\0';
8722         tz = my_getenv("TZ",0);
8723         if (tz) strcpy(envtz, tz);
8724         tz = my_getenv("UCX$TZ",0);
8725         if (tz) strcpy(ucxtz, tz);
8726         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
8727     }
8728     tz = envtz;
8729     if (!*tz) tz = ucxtz;
8730
8731     s = tz;
8732     while (isalpha(*s)) s++;
8733     s = tz_parse_offset(s, &std_off);
8734     if (!s) return 0;
8735     if (!*s) {                  /* no DST, hurray we're done! */
8736         isdst = 0;
8737         goto done;
8738     }
8739
8740     dstzone = s;
8741     while (isalpha(*s)) s++;
8742     s2 = tz_parse_offset(s, &dst_off);
8743     if (s2) {
8744         s = s2;
8745     } else {
8746         dst_off = std_off - 3600;
8747     }
8748
8749     if (!*s) {      /* default dst start/end?? */
8750         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
8751             s = strchr(ucxtz,',');
8752         }
8753         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
8754     }
8755     if (*s != ',') return 0;
8756
8757     when = *w;
8758     when = _toutc(when);      /* convert to utc */
8759     when = when - std_off;    /* convert to pseudolocal time*/
8760
8761     w2 = localtime(&when);
8762     y = w2->tm_year;
8763     s_start = s+1;
8764     s = tz_parse_startend(s_start,w2,&dststart);
8765     if (!s) return 0;
8766     if (*s != ',') return 0;
8767
8768     when = *w;
8769     when = _toutc(when);      /* convert to utc */
8770     when = when - dst_off;    /* convert to pseudolocal time*/
8771     w2 = localtime(&when);
8772     if (w2->tm_year != y) {   /* spans a year, just check one time */
8773         when += dst_off - std_off;
8774         w2 = localtime(&when);
8775     }
8776     s_end = s+1;
8777     s = tz_parse_startend(s_end,w2,&dstend);
8778     if (!s) return 0;
8779
8780     if (reversed == -1) {  /* need to check if start later than end */
8781         int j, ds, de;
8782
8783         when = *w;
8784         if (when < 2*365*86400) {
8785             when += 2*365*86400;
8786         } else {
8787             when -= 365*86400;
8788         }
8789         w2 =localtime(&when);
8790         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
8791
8792         for (j = 0; j < 12; j++) {
8793             w2 =localtime(&when);
8794             tz_parse_startend(s_start,w2,&ds);
8795             tz_parse_startend(s_end,w2,&de);
8796             if (ds != de) break;
8797             when += 30*86400;
8798         }
8799         reversed = 0;
8800         if (de && !ds) reversed = 1;
8801     }
8802
8803     isdst = dststart && !dstend;
8804     if (reversed) isdst = dststart  || !dstend;
8805
8806 done:
8807     if (dst)    *dst = isdst;
8808     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
8809     if (isdst)  tz = dstzone;
8810     if (zone) {
8811         while(isalpha(*tz))  *zone++ = *tz++;
8812         *zone = '\0';
8813     }
8814     return 1;
8815 }
8816
8817 #endif /* !RTL_USES_UTC */
8818
8819 /* my_time(), my_localtime(), my_gmtime()
8820  * By default traffic in UTC time values, using CRTL gmtime() or
8821  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
8822  * Note: We need to use these functions even when the CRTL has working
8823  * UTC support, since they also handle C<use vmsish qw(times);>
8824  *
8825  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
8826  * Modified by Charles Bailey <bailey@newman.upenn.edu>
8827  */
8828
8829 /*{{{time_t my_time(time_t *timep)*/
8830 time_t Perl_my_time(pTHX_ time_t *timep)
8831 {
8832   time_t when;
8833   struct tm *tm_p;
8834
8835   if (gmtime_emulation_type == 0) {
8836     int dstnow;
8837     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
8838                               /* results of calls to gmtime() and localtime() */
8839                               /* for same &base */
8840
8841     gmtime_emulation_type++;
8842     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
8843       char off[LNM$C_NAMLENGTH+1];;
8844
8845       gmtime_emulation_type++;
8846       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
8847         gmtime_emulation_type++;
8848         utc_offset_secs = 0;
8849         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
8850       }
8851       else { utc_offset_secs = atol(off); }
8852     }
8853     else { /* We've got a working gmtime() */
8854       struct tm gmt, local;
8855
8856       gmt = *tm_p;
8857       tm_p = localtime(&base);
8858       local = *tm_p;
8859       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
8860       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
8861       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
8862       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
8863     }
8864   }
8865
8866   when = time(NULL);
8867 # ifdef VMSISH_TIME
8868 # ifdef RTL_USES_UTC
8869   if (VMSISH_TIME) when = _toloc(when);
8870 # else
8871   if (!VMSISH_TIME) when = _toutc(when);
8872 # endif
8873 # endif
8874   if (timep != NULL) *timep = when;
8875   return when;
8876
8877 }  /* end of my_time() */
8878 /*}}}*/
8879
8880
8881 /*{{{struct tm *my_gmtime(const time_t *timep)*/
8882 struct tm *
8883 Perl_my_gmtime(pTHX_ const time_t *timep)
8884 {
8885   char *p;
8886   time_t when;
8887   struct tm *rsltmp;
8888
8889   if (timep == NULL) {
8890     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8891     return NULL;
8892   }
8893   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
8894
8895   when = *timep;
8896 # ifdef VMSISH_TIME
8897   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
8898 #  endif
8899 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
8900   return gmtime(&when);
8901 # else
8902   /* CRTL localtime() wants local time as input, so does no tz correction */
8903   rsltmp = localtime(&when);
8904   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
8905   return rsltmp;
8906 #endif
8907 }  /* end of my_gmtime() */
8908 /*}}}*/
8909
8910
8911 /*{{{struct tm *my_localtime(const time_t *timep)*/
8912 struct tm *
8913 Perl_my_localtime(pTHX_ const time_t *timep)
8914 {
8915   time_t when, whenutc;
8916   struct tm *rsltmp;
8917   int dst, offset;
8918
8919   if (timep == NULL) {
8920     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8921     return NULL;
8922   }
8923   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
8924   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
8925
8926   when = *timep;
8927 # ifdef RTL_USES_UTC
8928 # ifdef VMSISH_TIME
8929   if (VMSISH_TIME) when = _toutc(when);
8930 # endif
8931   /* CRTL localtime() wants UTC as input, does tz correction itself */
8932   return localtime(&when);
8933
8934 # else /* !RTL_USES_UTC */
8935   whenutc = when;
8936 # ifdef VMSISH_TIME
8937   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
8938   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
8939 # endif
8940   dst = -1;
8941 #ifndef RTL_USES_UTC
8942   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
8943       when = whenutc - offset;                   /* pseudolocal time*/
8944   }
8945 # endif
8946   /* CRTL localtime() wants local time as input, so does no tz correction */
8947   rsltmp = localtime(&when);
8948   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
8949   return rsltmp;
8950 # endif
8951
8952 } /*  end of my_localtime() */
8953 /*}}}*/
8954
8955 /* Reset definitions for later calls */
8956 #define gmtime(t)    my_gmtime(t)
8957 #define localtime(t) my_localtime(t)
8958 #define time(t)      my_time(t)
8959
8960
8961 /* my_utime - update modification time of a file
8962  * calling sequence is identical to POSIX utime(), but under
8963  * VMS only the modification time is changed; ODS-2 does not
8964  * maintain access times.  Restrictions differ from the POSIX
8965  * definition in that the time can be changed as long as the
8966  * caller has permission to execute the necessary IO$_MODIFY $QIO;
8967  * no separate checks are made to insure that the caller is the
8968  * owner of the file or has special privs enabled.
8969  * Code here is based on Joe Meadows' FILE utility.
8970  */
8971
8972 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
8973  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
8974  * in 100 ns intervals.
8975  */
8976 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
8977
8978 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
8979 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
8980 {
8981   register int i;
8982   int sts;
8983   long int bintime[2], len = 2, lowbit, unixtime,
8984            secscale = 10000000; /* seconds --> 100 ns intervals */
8985   unsigned long int chan, iosb[2], retsts;
8986   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
8987   struct FAB myfab = cc$rms_fab;
8988   struct NAM mynam = cc$rms_nam;
8989 #if defined (__DECC) && defined (__VAX)
8990   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
8991    * at least through VMS V6.1, which causes a type-conversion warning.
8992    */
8993 #  pragma message save
8994 #  pragma message disable cvtdiftypes
8995 #endif
8996   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
8997   struct fibdef myfib;
8998 #if defined (__DECC) && defined (__VAX)
8999   /* This should be right after the declaration of myatr, but due
9000    * to a bug in VAX DEC C, this takes effect a statement early.
9001    */
9002 #  pragma message restore
9003 #endif
9004   /* cast ok for read only parameter */
9005   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9006                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9007                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9008
9009   if (file == NULL || *file == '\0') {
9010     set_errno(ENOENT);
9011     set_vaxc_errno(LIB$_INVARG);
9012     return -1;
9013   }
9014   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
9015
9016   if (utimes != NULL) {
9017     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
9018      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9019      * Since time_t is unsigned long int, and lib$emul takes a signed long int
9020      * as input, we force the sign bit to be clear by shifting unixtime right
9021      * one bit, then multiplying by an extra factor of 2 in lib$emul().
9022      */
9023     lowbit = (utimes->modtime & 1) ? secscale : 0;
9024     unixtime = (long int) utimes->modtime;
9025 #   ifdef VMSISH_TIME
9026     /* If input was UTC; convert to local for sys svc */
9027     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9028 #   endif
9029     unixtime >>= 1;  secscale <<= 1;
9030     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9031     if (!(retsts & 1)) {
9032       set_errno(EVMSERR);
9033       set_vaxc_errno(retsts);
9034       return -1;
9035     }
9036     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9037     if (!(retsts & 1)) {
9038       set_errno(EVMSERR);
9039       set_vaxc_errno(retsts);
9040       return -1;
9041     }
9042   }
9043   else {
9044     /* Just get the current time in VMS format directly */
9045     retsts = sys$gettim(bintime);
9046     if (!(retsts & 1)) {
9047       set_errno(EVMSERR);
9048       set_vaxc_errno(retsts);
9049       return -1;
9050     }
9051   }
9052
9053   myfab.fab$l_fna = vmsspec;
9054   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9055   myfab.fab$l_nam = &mynam;
9056   mynam.nam$l_esa = esa;
9057   mynam.nam$b_ess = (unsigned char) sizeof esa;
9058   mynam.nam$l_rsa = rsa;
9059   mynam.nam$b_rss = (unsigned char) sizeof rsa;
9060   if (decc_efs_case_preserve)
9061       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9062
9063   /* Look for the file to be affected, letting RMS parse the file
9064    * specification for us as well.  I have set errno using only
9065    * values documented in the utime() man page for VMS POSIX.
9066    */
9067   retsts = sys$parse(&myfab,0,0);
9068   if (!(retsts & 1)) {
9069     set_vaxc_errno(retsts);
9070     if      (retsts == RMS$_PRV) set_errno(EACCES);
9071     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9072     else                         set_errno(EVMSERR);
9073     return -1;
9074   }
9075   retsts = sys$search(&myfab,0,0);
9076   if (!(retsts & 1)) {
9077     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9078     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9079     set_vaxc_errno(retsts);
9080     if      (retsts == RMS$_PRV) set_errno(EACCES);
9081     else if (retsts == RMS$_FNF) set_errno(ENOENT);
9082     else                         set_errno(EVMSERR);
9083     return -1;
9084   }
9085
9086   devdsc.dsc$w_length = mynam.nam$b_dev;
9087   /* cast ok for read only parameter */
9088   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9089
9090   retsts = sys$assign(&devdsc,&chan,0,0);
9091   if (!(retsts & 1)) {
9092     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9093     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9094     set_vaxc_errno(retsts);
9095     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
9096     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
9097     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
9098     else                               set_errno(EVMSERR);
9099     return -1;
9100   }
9101
9102   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9103   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9104
9105   memset((void *) &myfib, 0, sizeof myfib);
9106 #if defined(__DECC) || defined(__DECCXX)
9107   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9108   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9109   /* This prevents the revision time of the file being reset to the current
9110    * time as a result of our IO$_MODIFY $QIO. */
9111   myfib.fib$l_acctl = FIB$M_NORECORD;
9112 #else
9113   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9114   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9115   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9116 #endif
9117   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9118   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9119   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9120   _ckvmssts(sys$dassgn(chan));
9121   if (retsts & 1) retsts = iosb[0];
9122   if (!(retsts & 1)) {
9123     set_vaxc_errno(retsts);
9124     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9125     else                      set_errno(EVMSERR);
9126     return -1;
9127   }
9128
9129   return 0;
9130 }  /* end of my_utime() */
9131 /*}}}*/
9132
9133 /*
9134  * flex_stat, flex_lstat, flex_fstat
9135  * basic stat, but gets it right when asked to stat
9136  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9137  */
9138
9139 #ifndef _USE_STD_STAT
9140 /* encode_dev packs a VMS device name string into an integer to allow
9141  * simple comparisons. This can be used, for example, to check whether two
9142  * files are located on the same device, by comparing their encoded device
9143  * names. Even a string comparison would not do, because stat() reuses the
9144  * device name buffer for each call; so without encode_dev, it would be
9145  * necessary to save the buffer and use strcmp (this would mean a number of
9146  * changes to the standard Perl code, to say nothing of what a Perl script
9147  * would have to do.
9148  *
9149  * The device lock id, if it exists, should be unique (unless perhaps compared
9150  * with lock ids transferred from other nodes). We have a lock id if the disk is
9151  * mounted cluster-wide, which is when we tend to get long (host-qualified)
9152  * device names. Thus we use the lock id in preference, and only if that isn't
9153  * available, do we try to pack the device name into an integer (flagged by
9154  * the sign bit (LOCKID_MASK) being set).
9155  *
9156  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9157  * name and its encoded form, but it seems very unlikely that we will find
9158  * two files on different disks that share the same encoded device names,
9159  * and even more remote that they will share the same file id (if the test
9160  * is to check for the same file).
9161  *
9162  * A better method might be to use sys$device_scan on the first call, and to
9163  * search for the device, returning an index into the cached array.
9164  * The number returned would be more intelligable.
9165  * This is probably not worth it, and anyway would take quite a bit longer
9166  * on the first call.
9167  */
9168 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
9169 static mydev_t encode_dev (pTHX_ const char *dev)
9170 {
9171   int i;
9172   unsigned long int f;
9173   mydev_t enc;
9174   char c;
9175   const char *q;
9176
9177   if (!dev || !dev[0]) return 0;
9178
9179 #if LOCKID_MASK
9180   {
9181     struct dsc$descriptor_s dev_desc;
9182     unsigned long int status, lockid, item = DVI$_LOCKID;
9183
9184     /* For cluster-mounted disks, the disk lock identifier is unique, so we
9185        can try that first. */
9186     dev_desc.dsc$w_length =  strlen (dev);
9187     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
9188     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
9189     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
9190     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9191     if (lockid) return (lockid & ~LOCKID_MASK);
9192   }
9193 #endif
9194
9195   /* Otherwise we try to encode the device name */
9196   enc = 0;
9197   f = 1;
9198   i = 0;
9199   for (q = dev + strlen(dev); q--; q >= dev) {
9200     if (isdigit (*q))
9201       c= (*q) - '0';
9202     else if (isalpha (toupper (*q)))
9203       c= toupper (*q) - 'A' + (char)10;
9204     else
9205       continue; /* Skip '$'s */
9206     i++;
9207     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
9208     if (i>1) f *= 36;
9209     enc += f * (unsigned long int) c;
9210   }
9211   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
9212
9213 }  /* end of encode_dev() */
9214 #endif
9215
9216 static char namecache[NAM$C_MAXRSS+1];
9217
9218 static int
9219 is_null_device(name)
9220     const char *name;
9221 {
9222   if (decc_bug_devnull != 0) {
9223     if (strcmp("/dev/null", name) == 0) /* temp hack */
9224       return 1;
9225   }
9226     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9227        The underscore prefix, controller letter, and unit number are
9228        independently optional; for our purposes, the colon punctuation
9229        is not.  The colon can be trailed by optional directory and/or
9230        filename, but two consecutive colons indicates a nodename rather
9231        than a device.  [pr]  */
9232   if (*name == '_') ++name;
9233   if (tolower(*name++) != 'n') return 0;
9234   if (tolower(*name++) != 'l') return 0;
9235   if (tolower(*name) == 'a') ++name;
9236   if (*name == '0') ++name;
9237   return (*name++ == ':') && (*name != ':');
9238 }
9239
9240 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
9241 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9242  * subset of the applicable information.
9243  */
9244 bool
9245 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
9246 {
9247   char fname_phdev[NAM$C_MAXRSS+1];
9248 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9249   /* Namecache not workable with symbolic links, as symbolic links do
9250    *  not have extensions and directories do in VMS mode.  So in order
9251    *  to test this, the did and ino_t must be used.
9252    *
9253    * Fix-me - Hide the information in the new stat structure
9254    *          Get rid of the namecache.
9255    */
9256   if (decc_posix_compliant_pathnames == 0)
9257 #endif
9258       if (statbufp == &PL_statcache)
9259           return cando_by_name(bit,effective,namecache);
9260   {
9261     char fname[NAM$C_MAXRSS+1];
9262     unsigned long int retsts;
9263     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9264                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9265
9266     /* If the struct mystat is stale, we're OOL; stat() overwrites the
9267        device name on successive calls */
9268     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
9269     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
9270     namdsc.dsc$a_pointer = fname;
9271     namdsc.dsc$w_length = sizeof fname - 1;
9272
9273     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
9274                              &namdsc,&namdsc.dsc$w_length,0,0);
9275     if (retsts & 1) {
9276       fname[namdsc.dsc$w_length] = '\0';
9277 /*
9278  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
9279  * but if someone has redefined that logical, Perl gets very lost.  Since
9280  * we have the physical device name from the stat buffer, just paste it on.
9281  */
9282       strcpy( fname_phdev, statbufp->st_devnam );
9283       strcat( fname_phdev, strrchr(fname, ':') );
9284
9285       return cando_by_name(bit,effective,fname_phdev);
9286     }
9287     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
9288       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
9289       return FALSE;
9290     }
9291     _ckvmssts(retsts);
9292     return FALSE;  /* Should never get to here */
9293   }
9294 }  /* end of cando() */
9295 /*}}}*/
9296
9297
9298 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
9299 I32
9300 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
9301 {
9302   static char usrname[L_cuserid];
9303   static struct dsc$descriptor_s usrdsc =
9304          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
9305   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
9306   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
9307   unsigned short int retlen, trnlnm_iter_count;
9308   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9309   union prvdef curprv;
9310   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9311          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
9312   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9313          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9314          {0,0,0,0}};
9315   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
9316          {0,0,0,0}};
9317   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9318
9319   if (!fname || !*fname) return FALSE;
9320   /* Make sure we expand logical names, since sys$check_access doesn't */
9321   if (!strpbrk(fname,"/]>:")) {
9322     strcpy(fileified,fname);
9323     trnlnm_iter_count = 0;
9324     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
9325         trnlnm_iter_count++;
9326         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
9327     }
9328     fname = fileified;
9329   }
9330   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
9331   retlen = namdsc.dsc$w_length = strlen(vmsname);
9332   namdsc.dsc$a_pointer = vmsname;
9333   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
9334       vmsname[retlen-1] == ':') {
9335     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9336     namdsc.dsc$w_length = strlen(fileified);
9337     namdsc.dsc$a_pointer = fileified;
9338   }
9339
9340   switch (bit) {
9341     case S_IXUSR: case S_IXGRP: case S_IXOTH:
9342       access = ARM$M_EXECUTE; break;
9343     case S_IRUSR: case S_IRGRP: case S_IROTH:
9344       access = ARM$M_READ; break;
9345     case S_IWUSR: case S_IWGRP: case S_IWOTH:
9346       access = ARM$M_WRITE; break;
9347     case S_IDUSR: case S_IDGRP: case S_IDOTH:
9348       access = ARM$M_DELETE; break;
9349     default:
9350       return FALSE;
9351   }
9352
9353   /* Before we call $check_access, create a user profile with the current
9354    * process privs since otherwise it just uses the default privs from the
9355    * UAF and might give false positives or negatives.  This only works on
9356    * VMS versions v6.0 and later since that's when sys$create_user_profile
9357    * became available.
9358    */
9359
9360   /* get current process privs and username */
9361   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9362   _ckvmssts(iosb[0]);
9363
9364 #if defined(__VMS_VER) && __VMS_VER >= 60000000
9365
9366   /* find out the space required for the profile */
9367   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
9368                                     &usrprodsc.dsc$w_length,0));
9369
9370   /* allocate space for the profile and get it filled in */
9371   Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
9372   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
9373                                     &usrprodsc.dsc$w_length,0));
9374
9375   /* use the profile to check access to the file; free profile & analyze results */
9376   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
9377   Safefree(usrprodsc.dsc$a_pointer);
9378   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
9379
9380 #else
9381
9382   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
9383
9384 #endif
9385
9386   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
9387       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
9388       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
9389     set_vaxc_errno(retsts);
9390     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9391     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
9392     else set_errno(ENOENT);
9393     return FALSE;
9394   }
9395   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
9396     return TRUE;
9397   }
9398   _ckvmssts(retsts);
9399
9400   return FALSE;  /* Should never get here */
9401
9402 }  /* end of cando_by_name() */
9403 /*}}}*/
9404
9405
9406 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
9407 int
9408 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
9409 {
9410   if (!fstat(fd,(stat_t *) statbufp)) {
9411     if (statbufp == (Stat_t *) &PL_statcache) {
9412     char *cptr;
9413
9414         /* Save name for cando by name in VMS format */
9415         cptr = getname(fd, namecache, 1);
9416
9417         /* This should not happen, but just in case */
9418         if (cptr == NULL)
9419            namecache[0] = '\0';
9420     }
9421 #ifdef _USE_STD_STAT
9422     memcpy(&statbufp->st_ino, &statbufp->crtl_stat.st_ino, 8);
9423 #else
9424     memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9425 #endif
9426 #ifndef _USE_STD_STAT
9427     strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9428     statbufp->st_devnam[63] = 0;
9429     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9430 #else
9431     /* todo:
9432      * The device is only encoded so that Perl_cando can use it to
9433      * look up ACLS.  So rmsexpand it to the 255 character version
9434      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9435      * for long filenames and symbolic links first.  This also seems
9436      * to remove the need for a namecache that could be stale.
9437      */
9438 #endif
9439
9440 #   ifdef RTL_USES_UTC
9441 #   ifdef VMSISH_TIME
9442     if (VMSISH_TIME) {
9443       statbufp->st_mtime = _toloc(statbufp->st_mtime);
9444       statbufp->st_atime = _toloc(statbufp->st_atime);
9445       statbufp->st_ctime = _toloc(statbufp->st_ctime);
9446     }
9447 #   endif
9448 #   else
9449 #   ifdef VMSISH_TIME
9450     if (!VMSISH_TIME) { /* Return UTC instead of local time */
9451 #   else
9452     if (1) {
9453 #   endif
9454       statbufp->st_mtime = _toutc(statbufp->st_mtime);
9455       statbufp->st_atime = _toutc(statbufp->st_atime);
9456       statbufp->st_ctime = _toutc(statbufp->st_ctime);
9457     }
9458 #endif
9459     return 0;
9460   }
9461   return -1;
9462
9463 }  /* end of flex_fstat() */
9464 /*}}}*/
9465
9466 #if !defined(__VAX) && __CRTL_VER >= 80200000
9467 #ifdef lstat
9468 #undef lstat
9469 #endif
9470 #else
9471 #ifdef lstat
9472 #undef lstat
9473 #endif
9474 #define lstat(_x, _y) stat(_x, _y)
9475 #endif
9476
9477 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
9478
9479 static int
9480 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
9481 {
9482     char fileified[NAM$C_MAXRSS+1];
9483     char temp_fspec[NAM$C_MAXRSS+300];
9484     int retval = -1;
9485     int saved_errno, saved_vaxc_errno;
9486
9487     if (!fspec) return retval;
9488     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
9489     strcpy(temp_fspec, fspec);
9490     if (statbufp == (Stat_t *) &PL_statcache)
9491       do_tovmsspec(temp_fspec,namecache,0);
9492     if (decc_bug_devnull != 0) {
9493       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
9494         memset(statbufp,0,sizeof *statbufp);
9495         statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
9496         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
9497         statbufp->st_uid = 0x00010001;
9498         statbufp->st_gid = 0x0001;
9499         time((time_t *)&statbufp->st_mtime);
9500         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
9501         return 0;
9502       }
9503     }
9504
9505     /* Try for a directory name first.  If fspec contains a filename without
9506      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9507      * and sea:[wine.dark]water. exist, we prefer the directory here.
9508      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
9509      * not sea:[wine.dark]., if the latter exists.  If the intended target is
9510      * the file with null type, specify this by calling flex_stat() with
9511      * a '.' at the end of fspec.
9512      *
9513      * If we are in Posix filespec mode, accept the filename as is.
9514      */
9515 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9516   if (decc_posix_compliant_pathnames == 0) {
9517 #endif
9518     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
9519       if (lstat_flag == 0)
9520         retval = stat(fileified,(stat_t *) statbufp);
9521       else
9522         retval = lstat(fileified,(stat_t *) statbufp);
9523       if (!retval && statbufp == (Stat_t *) &PL_statcache)
9524         strcpy(namecache,fileified);
9525     }
9526     if (retval) {
9527       if (lstat_flag == 0)
9528         retval = stat(temp_fspec,(stat_t *) statbufp);
9529       else
9530         retval = lstat(temp_fspec,(stat_t *) statbufp);
9531     }
9532 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9533   } else {
9534     if (lstat_flag == 0)
9535       retval = stat(temp_fspec,(stat_t *) statbufp);
9536     else
9537       retval = lstat(temp_fspec,(stat_t *) statbufp);
9538   }
9539 #endif
9540     if (!retval) {
9541 #ifdef _USE_STD_STAT
9542       memcpy(&statbufp->st_ino, &statbufp->crtl_stat.st_ino, 8);
9543 #else
9544       memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9545 #endif
9546 #ifndef _USE_STD_STAT
9547       strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9548       statbufp->st_devnam[63] = 0;
9549       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9550 #else
9551     /* todo:
9552      * The device is only encoded so that Perl_cando can use it to
9553      * look up ACLS.  So rmsexpand it to the 255 character version
9554      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9555      * for long filenames and symbolic links first.  This also seems
9556      * to remove the need for a namecache that could be stale.
9557      */
9558 #endif
9559 #     ifdef RTL_USES_UTC
9560 #     ifdef VMSISH_TIME
9561       if (VMSISH_TIME) {
9562         statbufp->st_mtime = _toloc(statbufp->st_mtime);
9563         statbufp->st_atime = _toloc(statbufp->st_atime);
9564         statbufp->st_ctime = _toloc(statbufp->st_ctime);
9565       }
9566 #     endif
9567 #     else
9568 #     ifdef VMSISH_TIME
9569       if (!VMSISH_TIME) { /* Return UTC instead of local time */
9570 #     else
9571       if (1) {
9572 #     endif
9573         statbufp->st_mtime = _toutc(statbufp->st_mtime);
9574         statbufp->st_atime = _toutc(statbufp->st_atime);
9575         statbufp->st_ctime = _toutc(statbufp->st_ctime);
9576       }
9577 #     endif
9578     }
9579     /* If we were successful, leave errno where we found it */
9580     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
9581     return retval;
9582
9583 }  /* end of flex_stat_int() */
9584
9585
9586 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
9587 int
9588 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
9589 {
9590    return flex_stat_int(fspec, statbufp, 0);
9591 }
9592 /*}}}*/
9593
9594 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
9595 int
9596 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
9597 {
9598    return flex_stat_int(fspec, statbufp, 1);
9599 }
9600 /*}}}*/
9601
9602
9603 /*{{{char *my_getlogin()*/
9604 /* VMS cuserid == Unix getlogin, except calling sequence */
9605 char *
9606 my_getlogin(void)
9607 {
9608     static char user[L_cuserid];
9609     return cuserid(user);
9610 }
9611 /*}}}*/
9612
9613
9614 /*  rmscopy - copy a file using VMS RMS routines
9615  *
9616  *  Copies contents and attributes of spec_in to spec_out, except owner
9617  *  and protection information.  Name and type of spec_in are used as
9618  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
9619  *  should try to propagate timestamps from the input file to the output file.
9620  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
9621  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
9622  *  propagated to the output file at creation iff the output file specification
9623  *  did not contain an explicit name or type, and the revision date is always
9624  *  updated at the end of the copy operation.  If it is greater than 0, then
9625  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
9626  *  other than the revision date should be propagated, and bit 1 indicates
9627  *  that the revision date should be propagated.
9628  *
9629  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
9630  *
9631  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
9632  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
9633  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
9634  * as part of the Perl standard distribution under the terms of the
9635  * GNU General Public License or the Perl Artistic License.  Copies
9636  * of each may be found in the Perl standard distribution.
9637  */
9638 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
9639 int
9640 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
9641 {
9642     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
9643          rsa[NAM$C_MAXRSS], ubf[32256];
9644     unsigned long int i, sts, sts2;
9645     struct FAB fab_in, fab_out;
9646     struct RAB rab_in, rab_out;
9647     struct NAM nam;
9648     struct XABDAT xabdat;
9649     struct XABFHC xabfhc;
9650     struct XABRDT xabrdt;
9651     struct XABSUM xabsum;
9652
9653     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
9654         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
9655       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9656       return 0;
9657     }
9658
9659     fab_in = cc$rms_fab;
9660     fab_in.fab$l_fna = vmsin;
9661     fab_in.fab$b_fns = strlen(vmsin);
9662     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
9663     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
9664     fab_in.fab$l_fop = FAB$M_SQO;
9665     fab_in.fab$l_nam =  &nam;
9666     fab_in.fab$l_xab = (void *) &xabdat;
9667
9668     nam = cc$rms_nam;
9669     nam.nam$l_rsa = rsa;
9670     nam.nam$b_rss = sizeof(rsa);
9671     nam.nam$l_esa = esa;
9672     nam.nam$b_ess = sizeof (esa);
9673     nam.nam$b_esl = nam.nam$b_rsl = 0;
9674 #ifdef NAM$M_NO_SHORT_UPCASE
9675     if (decc_efs_case_preserve)
9676         nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9677 #endif
9678
9679     xabdat = cc$rms_xabdat;        /* To get creation date */
9680     xabdat.xab$l_nxt = (void *) &xabfhc;
9681
9682     xabfhc = cc$rms_xabfhc;        /* To get record length */
9683     xabfhc.xab$l_nxt = (void *) &xabsum;
9684
9685     xabsum = cc$rms_xabsum;        /* To get key and area information */
9686
9687     if (!((sts = sys$open(&fab_in)) & 1)) {
9688       set_vaxc_errno(sts);
9689       switch (sts) {
9690         case RMS$_FNF: case RMS$_DNF:
9691           set_errno(ENOENT); break;
9692         case RMS$_DIR:
9693           set_errno(ENOTDIR); break;
9694         case RMS$_DEV:
9695           set_errno(ENODEV); break;
9696         case RMS$_SYN:
9697           set_errno(EINVAL); break;
9698         case RMS$_PRV:
9699           set_errno(EACCES); break;
9700         default:
9701           set_errno(EVMSERR);
9702       }
9703       return 0;
9704     }
9705
9706     fab_out = fab_in;
9707     fab_out.fab$w_ifi = 0;
9708     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
9709     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
9710     fab_out.fab$l_fop = FAB$M_SQO;
9711     fab_out.fab$l_fna = vmsout;
9712     fab_out.fab$b_fns = strlen(vmsout);
9713     fab_out.fab$l_dna = nam.nam$l_name;
9714     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
9715
9716     if (preserve_dates == 0) {  /* Act like DCL COPY */
9717       nam.nam$b_nop |= NAM$M_SYNCHK;
9718       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
9719       if (!((sts = sys$parse(&fab_out)) & 1)) {
9720         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
9721         set_vaxc_errno(sts);
9722         return 0;
9723       }
9724       fab_out.fab$l_xab = (void *) &xabdat;
9725       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
9726     }
9727     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
9728     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
9729       preserve_dates =0;      /* bitmask from this point forward   */
9730
9731     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
9732     if (!((sts = sys$create(&fab_out)) & 1)) {
9733       set_vaxc_errno(sts);
9734       switch (sts) {
9735         case RMS$_DNF:
9736           set_errno(ENOENT); break;
9737         case RMS$_DIR:
9738           set_errno(ENOTDIR); break;
9739         case RMS$_DEV:
9740           set_errno(ENODEV); break;
9741         case RMS$_SYN:
9742           set_errno(EINVAL); break;
9743         case RMS$_PRV:
9744           set_errno(EACCES); break;
9745         default:
9746           set_errno(EVMSERR);
9747       }
9748       return 0;
9749     }
9750     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
9751     if (preserve_dates & 2) {
9752       /* sys$close() will process xabrdt, not xabdat */
9753       xabrdt = cc$rms_xabrdt;
9754 #ifndef __GNUC__
9755       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
9756 #else
9757       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
9758        * is unsigned long[2], while DECC & VAXC use a struct */
9759       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
9760 #endif
9761       fab_out.fab$l_xab = (void *) &xabrdt;
9762     }
9763
9764     rab_in = cc$rms_rab;
9765     rab_in.rab$l_fab = &fab_in;
9766     rab_in.rab$l_rop = RAB$M_BIO;
9767     rab_in.rab$l_ubf = ubf;
9768     rab_in.rab$w_usz = sizeof ubf;
9769     if (!((sts = sys$connect(&rab_in)) & 1)) {
9770       sys$close(&fab_in); sys$close(&fab_out);
9771       set_errno(EVMSERR); set_vaxc_errno(sts);
9772       return 0;
9773     }
9774
9775     rab_out = cc$rms_rab;
9776     rab_out.rab$l_fab = &fab_out;
9777     rab_out.rab$l_rbf = ubf;
9778     if (!((sts = sys$connect(&rab_out)) & 1)) {
9779       sys$close(&fab_in); sys$close(&fab_out);
9780       set_errno(EVMSERR); set_vaxc_errno(sts);
9781       return 0;
9782     }
9783
9784     while ((sts = sys$read(&rab_in))) {  /* always true  */
9785       if (sts == RMS$_EOF) break;
9786       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
9787       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
9788         sys$close(&fab_in); sys$close(&fab_out);
9789         set_errno(EVMSERR); set_vaxc_errno(sts);
9790         return 0;
9791       }
9792     }
9793
9794     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
9795     sys$close(&fab_in);  sys$close(&fab_out);
9796     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
9797     if (!(sts & 1)) {
9798       set_errno(EVMSERR); set_vaxc_errno(sts);
9799       return 0;
9800     }
9801
9802     return 1;
9803
9804 }  /* end of rmscopy() */
9805 /*}}}*/
9806
9807
9808 /***  The following glue provides 'hooks' to make some of the routines
9809  * from this file available from Perl.  These routines are sufficiently
9810  * basic, and are required sufficiently early in the build process,
9811  * that's it's nice to have them available to miniperl as well as the
9812  * full Perl, so they're set up here instead of in an extension.  The
9813  * Perl code which handles importation of these names into a given
9814  * package lives in [.VMS]Filespec.pm in @INC.
9815  */
9816
9817 void
9818 rmsexpand_fromperl(pTHX_ CV *cv)
9819 {
9820   dXSARGS;
9821   char *fspec, *defspec = NULL, *rslt;
9822   STRLEN n_a;
9823
9824   if (!items || items > 2)
9825     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
9826   fspec = SvPV(ST(0),n_a);
9827   if (!fspec || !*fspec) XSRETURN_UNDEF;
9828   if (items == 2) defspec = SvPV(ST(1),n_a);
9829
9830   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
9831   ST(0) = sv_newmortal();
9832   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
9833   XSRETURN(1);
9834 }
9835
9836 void
9837 vmsify_fromperl(pTHX_ CV *cv)
9838 {
9839   dXSARGS;
9840   char *vmsified;
9841   STRLEN n_a;
9842
9843   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
9844   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
9845   ST(0) = sv_newmortal();
9846   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
9847   XSRETURN(1);
9848 }
9849
9850 void
9851 unixify_fromperl(pTHX_ CV *cv)
9852 {
9853   dXSARGS;
9854   char *unixified;
9855   STRLEN n_a;
9856
9857   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
9858   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
9859   ST(0) = sv_newmortal();
9860   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
9861   XSRETURN(1);
9862 }
9863
9864 void
9865 fileify_fromperl(pTHX_ CV *cv)
9866 {
9867   dXSARGS;
9868   char *fileified;
9869   STRLEN n_a;
9870
9871   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
9872   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
9873   ST(0) = sv_newmortal();
9874   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
9875   XSRETURN(1);
9876 }
9877
9878 void
9879 pathify_fromperl(pTHX_ CV *cv)
9880 {
9881   dXSARGS;
9882   char *pathified;
9883   STRLEN n_a;
9884
9885   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
9886   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
9887   ST(0) = sv_newmortal();
9888   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
9889   XSRETURN(1);
9890 }
9891
9892 void
9893 vmspath_fromperl(pTHX_ CV *cv)
9894 {
9895   dXSARGS;
9896   char *vmspath;
9897   STRLEN n_a;
9898
9899   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
9900   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
9901   ST(0) = sv_newmortal();
9902   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
9903   XSRETURN(1);
9904 }
9905
9906 void
9907 unixpath_fromperl(pTHX_ CV *cv)
9908 {
9909   dXSARGS;
9910   char *unixpath;
9911   STRLEN n_a;
9912
9913   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
9914   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
9915   ST(0) = sv_newmortal();
9916   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
9917   XSRETURN(1);
9918 }
9919
9920 void
9921 candelete_fromperl(pTHX_ CV *cv)
9922 {
9923   dXSARGS;
9924   char fspec[NAM$C_MAXRSS+1], *fsp;
9925   SV *mysv;
9926   IO *io;
9927   STRLEN n_a;
9928
9929   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
9930
9931   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
9932   if (SvTYPE(mysv) == SVt_PVGV) {
9933     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
9934       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9935       ST(0) = &PL_sv_no;
9936       XSRETURN(1);
9937     }
9938     fsp = fspec;
9939   }
9940   else {
9941     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
9942       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9943       ST(0) = &PL_sv_no;
9944       XSRETURN(1);
9945     }
9946   }
9947
9948   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
9949   XSRETURN(1);
9950 }
9951
9952 void
9953 rmscopy_fromperl(pTHX_ CV *cv)
9954 {
9955   dXSARGS;
9956   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
9957   int date_flag;
9958   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9959                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9960   unsigned long int sts;
9961   SV *mysv;
9962   IO *io;
9963   STRLEN n_a;
9964
9965   if (items < 2 || items > 3)
9966     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
9967
9968   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
9969   if (SvTYPE(mysv) == SVt_PVGV) {
9970     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
9971       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9972       ST(0) = &PL_sv_no;
9973       XSRETURN(1);
9974     }
9975     inp = inspec;
9976   }
9977   else {
9978     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
9979       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9980       ST(0) = &PL_sv_no;
9981       XSRETURN(1);
9982     }
9983   }
9984   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
9985   if (SvTYPE(mysv) == SVt_PVGV) {
9986     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
9987       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9988       ST(0) = &PL_sv_no;
9989       XSRETURN(1);
9990     }
9991     outp = outspec;
9992   }
9993   else {
9994     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
9995       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9996       ST(0) = &PL_sv_no;
9997       XSRETURN(1);
9998     }
9999   }
10000   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
10001
10002   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
10003   XSRETURN(1);
10004 }
10005
10006
10007 void
10008 mod2fname(pTHX_ CV *cv)
10009 {
10010   dXSARGS;
10011   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10012        workbuff[NAM$C_MAXRSS*1 + 1];
10013   int total_namelen = 3, counter, num_entries;
10014   /* ODS-5 ups this, but we want to be consistent, so... */
10015   int max_name_len = 39;
10016   AV *in_array = (AV *)SvRV(ST(0));
10017
10018   num_entries = av_len(in_array);
10019
10020   /* All the names start with PL_. */
10021   strcpy(ultimate_name, "PL_");
10022
10023   /* Clean up our working buffer */
10024   Zero(work_name, sizeof(work_name), char);
10025
10026   /* Run through the entries and build up a working name */
10027   for(counter = 0; counter <= num_entries; counter++) {
10028     /* If it's not the first name then tack on a __ */
10029     if (counter) {
10030       strcat(work_name, "__");
10031     }
10032     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10033                            PL_na));
10034   }
10035
10036   /* Check to see if we actually have to bother...*/
10037   if (strlen(work_name) + 3 <= max_name_len) {
10038     strcat(ultimate_name, work_name);
10039   } else {
10040     /* It's too darned big, so we need to go strip. We use the same */
10041     /* algorithm as xsubpp does. First, strip out doubled __ */
10042     char *source, *dest, last;
10043     dest = workbuff;
10044     last = 0;
10045     for (source = work_name; *source; source++) {
10046       if (last == *source && last == '_') {
10047         continue;
10048       }
10049       *dest++ = *source;
10050       last = *source;
10051     }
10052     /* Go put it back */
10053     strcpy(work_name, workbuff);
10054     /* Is it still too big? */
10055     if (strlen(work_name) + 3 > max_name_len) {
10056       /* Strip duplicate letters */
10057       last = 0;
10058       dest = workbuff;
10059       for (source = work_name; *source; source++) {
10060         if (last == toupper(*source)) {
10061         continue;
10062         }
10063         *dest++ = *source;
10064         last = toupper(*source);
10065       }
10066       strcpy(work_name, workbuff);
10067     }
10068
10069     /* Is it *still* too big? */
10070     if (strlen(work_name) + 3 > max_name_len) {
10071       /* Too bad, we truncate */
10072       work_name[max_name_len - 2] = 0;
10073     }
10074     strcat(ultimate_name, work_name);
10075   }
10076
10077   /* Okay, return it */
10078   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10079   XSRETURN(1);
10080 }
10081
10082 void
10083 hushexit_fromperl(pTHX_ CV *cv)
10084 {
10085     dXSARGS;
10086
10087     if (items > 0) {
10088         VMSISH_HUSHED = SvTRUE(ST(0));
10089     }
10090     ST(0) = boolSV(VMSISH_HUSHED);
10091     XSRETURN(1);
10092 }
10093
10094 #ifdef HAS_SYMLINK
10095 static char *
10096 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10097
10098 void
10099 vms_realpath_fromperl(pTHX_ CV *cv)
10100 {
10101   dXSARGS;
10102   char *fspec, *rslt_spec, *rslt;
10103   STRLEN n_a;
10104
10105   if (!items || items != 1)
10106     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
10107
10108   fspec = SvPV(ST(0),n_a);
10109   if (!fspec || !*fspec) XSRETURN_UNDEF;
10110
10111   Newx(rslt_spec, VMS_MAXRSS + 1, char);
10112   rslt = do_vms_realpath(fspec, rslt_spec);
10113   ST(0) = sv_newmortal();
10114   if (rslt != NULL)
10115     sv_usepvn(ST(0),rslt,strlen(rslt));
10116   else
10117     Safefree(rslt_spec);
10118   XSRETURN(1);
10119 }
10120 #endif
10121
10122 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10123 int do_vms_case_tolerant(void);
10124
10125 void
10126 vms_case_tolerant_fromperl(pTHX_ CV *cv)
10127 {
10128   dXSARGS;
10129   ST(0) = boolSV(do_vms_case_tolerant());
10130   XSRETURN(1);
10131 }
10132 #endif
10133
10134 void
10135 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
10136                           struct interp_intern *dst)
10137 {
10138     memcpy(dst,src,sizeof(struct interp_intern));
10139 }
10140
10141 void
10142 Perl_sys_intern_clear(pTHX)
10143 {
10144 }
10145
10146 void
10147 Perl_sys_intern_init(pTHX)
10148 {
10149     unsigned int ix = RAND_MAX;
10150     double x;
10151
10152     VMSISH_HUSHED = 0;
10153
10154     /* fix me later to track running under GNV */
10155     /* this allows some limited testing */
10156     MY_POSIX_EXIT = decc_filename_unix_report;
10157
10158     x = (float)ix;
10159     MY_INV_RAND_MAX = 1./x;
10160 }
10161
10162 void
10163 init_os_extras(void)
10164 {
10165   dTHX;
10166   char* file = __FILE__;
10167   char temp_buff[512];
10168   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
10169     no_translate_barewords = TRUE;
10170   } else {
10171     no_translate_barewords = FALSE;
10172   }
10173
10174   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
10175   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
10176   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
10177   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
10178   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
10179   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
10180   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
10181   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
10182   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
10183   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
10184   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
10185 #ifdef HAS_SYMLINK
10186   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
10187 #endif
10188 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10189   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
10190 #endif
10191
10192   store_pipelocs(aTHX);         /* will redo any earlier attempts */
10193
10194   return;
10195 }
10196
10197 #ifdef HAS_SYMLINK
10198
10199 #if __CRTL_VER == 80200000
10200 /* This missed getting in to the DECC SDK for 8.2 */
10201 char *realpath(const char *file_name, char * resolved_name, ...);
10202 #endif
10203
10204 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
10205 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
10206  * The perl fallback routine to provide realpath() is not as efficient
10207  * on OpenVMS.
10208  */
10209 static char *
10210 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10211 {
10212     return realpath(filespec, outbuf);
10213 }
10214
10215 /*}}}*/
10216 /* External entry points */
10217 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10218 { return do_vms_realpath(filespec, outbuf); }
10219 #else
10220 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10221 { return NULL; }
10222 #endif
10223
10224
10225 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10226 /* case_tolerant */
10227
10228 /*{{{int do_vms_case_tolerant(void)*/
10229 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
10230  * controlled by a process setting.
10231  */
10232 int do_vms_case_tolerant(void)
10233 {
10234     return vms_process_case_tolerant;
10235 }
10236 /*}}}*/
10237 /* External entry points */
10238 int Perl_vms_case_tolerant(void)
10239 { return do_vms_case_tolerant(); }
10240 #else
10241 int Perl_vms_case_tolerant(void)
10242 { return vms_process_case_tolerant; }
10243 #endif
10244
10245
10246  /* Start of DECC RTL Feature handling */
10247
10248 static int sys_trnlnm
10249    (const char * logname,
10250     char * value,
10251     int value_len)
10252 {
10253     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
10254     const unsigned long attr = LNM$M_CASE_BLIND;
10255     struct dsc$descriptor_s name_dsc;
10256     int status;
10257     unsigned short result;
10258     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
10259                                 {0, 0, 0, 0}};
10260
10261     name_dsc.dsc$w_length = strlen(logname);
10262     name_dsc.dsc$a_pointer = (char *)logname;
10263     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10264     name_dsc.dsc$b_class = DSC$K_CLASS_S;
10265
10266     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
10267
10268     if ($VMS_STATUS_SUCCESS(status)) {
10269
10270          /* Null terminate and return the string */
10271         /*--------------------------------------*/
10272         value[result] = 0;
10273     }
10274
10275     return status;
10276 }
10277
10278 static int sys_crelnm
10279    (const char * logname,
10280     const char * value)
10281 {
10282     int ret_val;
10283     const char * proc_table = "LNM$PROCESS_TABLE";
10284     struct dsc$descriptor_s proc_table_dsc;
10285     struct dsc$descriptor_s logname_dsc;
10286     struct itmlst_3 item_list[2];
10287
10288     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
10289     proc_table_dsc.dsc$w_length = strlen(proc_table);
10290     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10291     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
10292
10293     logname_dsc.dsc$a_pointer = (char *) logname;
10294     logname_dsc.dsc$w_length = strlen(logname);
10295     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10296     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
10297
10298     item_list[0].buflen = strlen(value);
10299     item_list[0].itmcode = LNM$_STRING;
10300     item_list[0].bufadr = (char *)value;
10301     item_list[0].retlen = NULL;
10302
10303     item_list[1].buflen = 0;
10304     item_list[1].itmcode = 0;
10305
10306     ret_val = sys$crelnm
10307                        (NULL,
10308                         (const struct dsc$descriptor_s *)&proc_table_dsc,
10309                         (const struct dsc$descriptor_s *)&logname_dsc,
10310                         NULL,
10311                         (const struct item_list_3 *) item_list);
10312
10313     return ret_val;
10314 }
10315
10316
10317 /* C RTL Feature settings */
10318
10319 static int set_features
10320    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
10321     int (* cli_routine)(void),  /* Not documented */
10322     void *image_info)           /* Not documented */
10323 {
10324     int status;
10325     int s;
10326     int dflt;
10327     char* str;
10328     char val_str[10];
10329     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
10330     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
10331     unsigned long case_perm;
10332     unsigned long case_image;
10333
10334     /* hacks to see if known bugs are still present for testing */
10335
10336     /* Readdir is returning filenames in VMS syntax always */
10337     decc_bug_readdir_efs1 = 1;
10338     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
10339     if ($VMS_STATUS_SUCCESS(status)) {
10340        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10341          decc_bug_readdir_efs1 = 1;
10342        else
10343          decc_bug_readdir_efs1 = 0;
10344     }
10345
10346     /* PCP mode requires creating /dev/null special device file */
10347     decc_bug_devnull = 0;
10348     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
10349     if ($VMS_STATUS_SUCCESS(status)) {
10350        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10351           decc_bug_devnull = 1;
10352     }
10353
10354     /* fgetname returning a VMS name in UNIX mode */
10355     decc_bug_fgetname = 1;
10356     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
10357     if ($VMS_STATUS_SUCCESS(status)) {
10358       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10359         decc_bug_fgetname = 1;
10360       else
10361         decc_bug_fgetname = 0;
10362     }
10363
10364     /* UNIX directory names with no paths are broken in a lot of places */
10365     decc_dir_barename = 1;
10366     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
10367     if ($VMS_STATUS_SUCCESS(status)) {
10368       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10369         decc_dir_barename = 1;
10370       else
10371         decc_dir_barename = 0;
10372     }
10373
10374 #if __CRTL_VER >= 70300000 && !defined(__VAX)
10375     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
10376     if (s >= 0) {
10377         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
10378         if (decc_disable_to_vms_logname_translation < 0)
10379             decc_disable_to_vms_logname_translation = 0;
10380     }
10381
10382     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
10383     if (s >= 0) {
10384         decc_efs_case_preserve = decc$feature_get_value(s, 1);
10385         if (decc_efs_case_preserve < 0)
10386             decc_efs_case_preserve = 0;
10387     }
10388
10389     s = decc$feature_get_index("DECC$EFS_CHARSET");
10390     if (s >= 0) {
10391         decc_efs_charset = decc$feature_get_value(s, 1);
10392         if (decc_efs_charset < 0)
10393             decc_efs_charset = 0;
10394     }
10395
10396     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
10397     if (s >= 0) {
10398         decc_filename_unix_report = decc$feature_get_value(s, 1);
10399         if (decc_filename_unix_report > 0)
10400             decc_filename_unix_report = 1;
10401         else
10402             decc_filename_unix_report = 0;
10403     }
10404
10405     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
10406     if (s >= 0) {
10407         decc_filename_unix_only = decc$feature_get_value(s, 1);
10408         if (decc_filename_unix_only > 0) {
10409             decc_filename_unix_only = 1;
10410         }
10411         else {
10412             decc_filename_unix_only = 0;
10413         }
10414     }
10415
10416     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
10417     if (s >= 0) {
10418         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
10419         if (decc_filename_unix_no_version < 0)
10420             decc_filename_unix_no_version = 0;
10421     }
10422
10423     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
10424     if (s >= 0) {
10425         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
10426         if (decc_readdir_dropdotnotype < 0)
10427             decc_readdir_dropdotnotype = 0;
10428     }
10429
10430     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
10431     if ($VMS_STATUS_SUCCESS(status)) {
10432         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
10433         if (s >= 0) {
10434             dflt = decc$feature_get_value(s, 4);
10435             if (dflt > 0) {
10436                 decc_disable_posix_root = decc$feature_get_value(s, 1);
10437                 if (decc_disable_posix_root <= 0) {
10438                     decc$feature_set_value(s, 1, 1);
10439                     decc_disable_posix_root = 1;
10440                 }
10441             }
10442             else {
10443                 /* Traditionally Perl assumes this is off */
10444                 decc_disable_posix_root = 1;
10445                 decc$feature_set_value(s, 1, 1);
10446             }
10447         }
10448     }
10449
10450 #if __CRTL_VER >= 80200000
10451     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
10452     if (s >= 0) {
10453         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
10454         if (decc_posix_compliant_pathnames < 0)
10455             decc_posix_compliant_pathnames = 0;
10456         if (decc_posix_compliant_pathnames > 4)
10457             decc_posix_compliant_pathnames = 0;
10458     }
10459
10460 #endif
10461 #else
10462     status = sys_trnlnm
10463         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
10464     if ($VMS_STATUS_SUCCESS(status)) {
10465         val_str[0] = _toupper(val_str[0]);
10466         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10467            decc_disable_to_vms_logname_translation = 1;
10468         }
10469     }
10470
10471 #ifndef __VAX
10472     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
10473     if ($VMS_STATUS_SUCCESS(status)) {
10474         val_str[0] = _toupper(val_str[0]);
10475         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10476            decc_efs_case_preserve = 1;
10477         }
10478     }
10479 #endif
10480
10481     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
10482     if ($VMS_STATUS_SUCCESS(status)) {
10483         val_str[0] = _toupper(val_str[0]);
10484         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10485            decc_filename_unix_report = 1;
10486         }
10487     }
10488     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
10489     if ($VMS_STATUS_SUCCESS(status)) {
10490         val_str[0] = _toupper(val_str[0]);
10491         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10492            decc_filename_unix_only = 1;
10493            decc_filename_unix_report = 1;
10494         }
10495     }
10496     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
10497     if ($VMS_STATUS_SUCCESS(status)) {
10498         val_str[0] = _toupper(val_str[0]);
10499         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10500            decc_filename_unix_no_version = 1;
10501         }
10502     }
10503     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
10504     if ($VMS_STATUS_SUCCESS(status)) {
10505         val_str[0] = _toupper(val_str[0]);
10506         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10507            decc_readdir_dropdotnotype = 1;
10508         }
10509     }
10510 #endif
10511
10512 #ifndef __VAX
10513
10514      /* Report true case tolerance */
10515     /*----------------------------*/
10516     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
10517     if (!$VMS_STATUS_SUCCESS(status))
10518         case_perm = PPROP$K_CASE_BLIND;
10519     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
10520     if (!$VMS_STATUS_SUCCESS(status))
10521         case_image = PPROP$K_CASE_BLIND;
10522     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
10523         (case_image == PPROP$K_CASE_SENSITIVE))
10524         vms_process_case_tolerant = 0;
10525
10526 #endif
10527
10528
10529     /* CRTL can be initialized past this point, but not before. */
10530 /*    DECC$CRTL_INIT(); */
10531
10532     return SS$_NORMAL;
10533 }
10534
10535 #ifdef __DECC
10536 /* DECC dependent attributes */
10537 #if __DECC_VER < 60560002
10538 #define relative
10539 #define not_executable
10540 #else
10541 #define relative ,rel
10542 #define not_executable ,noexe
10543 #endif
10544 #pragma nostandard
10545 #pragma extern_model save
10546 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
10547 #endif
10548         const __align (LONGWORD) int spare[8] = {0};
10549 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
10550 /*                        NOWRT, LONG */
10551 #ifdef __DECC
10552 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
10553         nowrt,noshr relative not_executable
10554 #endif
10555 const long vms_cc_features = (const long)set_features;
10556
10557 /*
10558 ** Force a reference to LIB$INITIALIZE to ensure it
10559 ** exists in the image.
10560 */
10561 int lib$initialize(void);
10562 #ifdef __DECC
10563 #pragma extern_model strict_refdef
10564 #endif
10565     int lib_init_ref = (int) lib$initialize;
10566
10567 #ifdef __DECC
10568 #pragma extern_model restore
10569 #pragma standard
10570 #endif
10571
10572 /*  End of vms.c */