vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  * Version: 5.7.0
   5  *
   6  * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
   7  *             and Perl_cando by Craig Berry
   8  * 29-Aug-2000 Charles Lane's piping improvements rolled in
   9  * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  10  */
  11
  12 #include <acedef.h>
  13 #include <acldef.h>
  14 #include <armdef.h>
  15 #include <atrdef.h>
  16 #include <chpdef.h>
  17 #include <clidef.h>
  18 #include <climsgdef.h>
  19 #include <descrip.h>
  20 #include <devdef.h>
  21 #include <dvidef.h>
  22 #include <fibdef.h>
  23 #include <float.h>
  24 #include <fscndef.h>
  25 #include <iodef.h>
  26 #include <jpidef.h>
  27 #include <kgbdef.h>
  28 #include <libclidef.h>
  29 #include <libdef.h>
  30 #include <lib$routines.h>
  31 #include <lnmdef.h>
  32 #include <msgdef.h>
  33 #include <prvdef.h>
  34 #include <psldef.h>
  35 #include <rms.h>
  36 #include <shrdef.h>
  37 #include <ssdef.h>
  38 #include <starlet.h>
  39 #include <strdef.h>
  40 #include <str$routines.h>
  41 #include <syidef.h>
  42 #include <uaidef.h>
  43 #include <uicdef.h>
  44
  45 /* Older versions of ssdef.h don't have these */
  46 #ifndef SS$_INVFILFOROP
  47 #  define SS$_INVFILFOROP 3930
  48 #endif
  49 #ifndef SS$_NOSUCHOBJECT
  50 #  define SS$_NOSUCHOBJECT 2696
  51 #endif
  52
  53 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
  54 #define PERLIO_NOT_STDIO 0
  55
  56 /* Don't replace system definitions of vfork, getenv, and stat,
  57  * code below needs to get to the underlying CRTL routines. */
  58 #define DONT_MASK_RTL_CALLS
  59 #include "EXTERN.h"
  60 #include "perl.h"
  61 #include "XSUB.h"
  62 /* Anticipating future expansion in lexical warnings . . . */
  63 #ifndef WARN_INTERNAL
  64 #  define WARN_INTERNAL WARN_MISC
  65 #endif
  66
  67 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
  68 #  define RTL_USES_UTC 1
  69 #endif
  70
  71
  72 /* gcc's header files don't #define direct access macros
  73  * corresponding to VAXC's variant structs */
  74 #ifdef __GNUC__
  75 #  define uic$v_format uic$r_uic_form.uic$v_format
  76 #  define uic$v_group uic$r_uic_form.uic$v_group
  77 #  define uic$v_member uic$r_uic_form.uic$v_member
  78 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
  79 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
  80 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
  81 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
  82 #endif
  83
  84 #if defined(NEED_AN_H_ERRNO)
  85 dEXT int h_errno;
  86 #endif
  87
  88 struct itmlst_3 {
  89   unsigned short int buflen;
  90   unsigned short int itmcode;
  91   void *bufadr;
  92   unsigned short int *retlen;
  93 };
  94
  95 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
  96 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
  97 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
  98 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
  99 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
 100 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
 101 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
 102 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 103 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 104
 105 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 106 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 107
 108 #define MAX_DCL_SYMBOL              255     /* well, what *we* can set, at least*/
 109 #define MAX_DCL_LINE_LENGTH        (4*MAX_DCL_SYMBOL-4)
 110
 111 static char *__mystrtolower(char *str)
 112 {
 113   if (str) for (; *str; ++str) *str= tolower(*str);
 114   return str;
 115 }
 116
 117 static struct dsc$descriptor_s fildevdsc =
 118   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 119 static struct dsc$descriptor_s crtlenvdsc =
 120   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 121 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 122 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 123 static struct dsc$descriptor_s **env_tables = defenv;
 124 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 125
 126 /* True if we shouldn't treat barewords as logicals during directory */
 127 /* munching */
 128 static int no_translate_barewords;
 129
 130 #ifndef RTL_USES_UTC
 131 static int tz_updated = 1;
 132 #endif
 133
 134 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 135 int
 136 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 137   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 138 {
 139     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
 140     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 141     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 142     unsigned char acmode;
 143     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 144                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 145     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 146                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 147                                  {0, 0, 0, 0}};
 148     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 149 #if defined(PERL_IMPLICIT_CONTEXT)
 150     pTHX = NULL;
 151 #  if defined(USE_5005THREADS)
 152     /* We jump through these hoops because we can be called at */
 153     /* platform-specific initialization time, which is before anything is */
 154     /* set up--we can't even do a plain dTHX since that relies on the */
 155     /* interpreter structure to be initialized */
 156     if (PL_curinterp) {
 157       aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
 158     } else {
 159       aTHX = NULL;
 160     }
 161 # else
 162     if (PL_curinterp) {
 163       aTHX = PERL_GET_INTERP;
 164     } else {
 165       aTHX = NULL;
 166     }
 167
 168 #  endif
 169 #endif
 170
 171     if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
 172       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 173     }
 174     for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 175       *cp2 = _toupper(*cp1);
 176       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 177         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 178         return 0;
 179       }
 180     }
 181     lnmdsc.dsc$w_length = cp1 - lnm;
 182     lnmdsc.dsc$a_pointer = uplnm;
 183     uplnm[lnmdsc.dsc$w_length] = '\0';
 184     secure = flags & PERL__TRNENV_SECURE;
 185     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 186     if (!tabvec || !*tabvec) tabvec = env_tables;
 187
 188     for (curtab = 0; tabvec[curtab]; curtab++) {
 189       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 190         if (!ivenv && !secure) {
 191           char *eq, *end;
 192           int i;
 193           if (!environ) {
 194             ivenv = 1;
 195             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 196             continue;
 197           }
 198           retsts = SS$_NOLOGNAM;
 199           for (i = 0; environ[i]; i++) {
 200             if ((eq = strchr(environ[i],'=')) &&
 201                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 202               eq++;
 203               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 204               if (!eqvlen) continue;
 205               retsts = SS$_NORMAL;
 206               break;
 207             }
 208           }
 209           if (retsts != SS$_NOLOGNAM) break;
 210         }
 211       }
 212       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 213                !str$case_blind_compare(&tmpdsc,&clisym)) {
 214         if (!ivsym && !secure) {
 215           unsigned short int deflen = LNM$C_NAMLENGTH;
 216           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 217           /* dynamic dsc to accomodate possible long value */
 218           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 219           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 220           if (retsts & 1) {
 221             if (eqvlen > 1024) {
 222               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 223               eqvlen = 1024;
 224               /* Special hack--we might be called before the interpreter's */
 225               /* fully initialized, in which case either thr or PL_curcop */
 226               /* might be bogus. We have to check, since ckWARN needs them */
 227               /* both to be valid if running threaded */
 228 #if defined(USE_5005THREADS)
 229               if (thr && PL_curcop) {
 230 #endif
 231                 if (ckWARN(WARN_MISC)) {
 232                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 233                 }
 234 #if defined(USE_5005THREADS)
 235               } else {
 236                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 237               }
 238 #endif
 239
 240             }
 241             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 242           }
 243           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 244           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 245           if (retsts == LIB$_NOSUCHSYM) continue;
 246           break;
 247         }
 248       }
 249       else if (!ivlnm) {
 250         retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 251         if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 252         if (retsts == SS$_NOLOGNAM) continue;
 253         /* PPFs have a prefix */
 254         if (
 255 #if INTSIZE == 4
 256              *((int *)uplnm) == *((int *)"SYS$")                    &&
 257 #endif
 258              eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 259              ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 260                (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 261                (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 262                (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 263           memcpy(eqv,eqv+4,eqvlen-4);
 264           eqvlen -= 4;
 265         }
 266         break;
 267       }
 268     }
 269     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 270     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 271              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 272              retsts == SS$_NOLOGNAM) {
 273       set_errno(EINVAL);  set_vaxc_errno(retsts);
 274     }
 275     else _ckvmssts(retsts);
 276     return 0;
 277 }  /* end of vmstrnenv */
 278 /*}}}*/
 279
 280 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 281 /* Define as a function so we can access statics. */
 282 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 283 {
 284   return vmstrnenv(lnm,eqv,idx,fildev,
 285 #ifdef SECURE_INTERNAL_GETENV
 286                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 287 #else
 288                    0
 289 #endif
 290                                                                               );
 291 }
 292 /*}}}*/
 293
 294 /* my_getenv
 295  * Note: Uses Perl temp to store result so char * can be returned to
 296  * caller; this pointer will be invalidated at next Perl statement
 297  * transition.
 298  * We define this as a function rather than a macro in terms of my_getenv_len()
 299  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 300  * allocate SVs).
 301  */
 302 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 303 char *
 304 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 305 {
 306     static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
 307     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
 308     unsigned long int idx = 0;
 309     int trnsuccess, success, secure, saverr, savvmserr;
 310     SV *tmpsv;
 311
 312     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 313       /* Set up a temporary buffer for the return value; Perl will
 314        * clean it up at the next statement transition */
 315       tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
 316       if (!tmpsv) return NULL;
 317       eqv = SvPVX(tmpsv);
 318     }
 319     else eqv = __my_getenv_eqv;  /* Assume no interpreter ==> single thread */
 320     for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 321     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 322       getcwd(eqv,LNM$C_NAMLENGTH);
 323       return eqv;
 324     }
 325     else {
 326       if ((cp2 = strchr(lnm,';')) != NULL) {
 327         strcpy(uplnm,lnm);
 328         uplnm[cp2-lnm] = '\0';
 329         idx = strtoul(cp2+1,NULL,0);
 330         lnm = uplnm;
 331       }
 332       /* Impose security constraints only if tainting */
 333       if (sys) {
 334         /* Impose security constraints only if tainting */
 335         secure = PL_curinterp ? PL_tainting : will_taint;
 336         saverr = errno;  savvmserr = vaxc$errno;
 337       }
 338       else secure = 0;
 339       success = vmstrnenv(lnm,eqv,idx,
 340                           secure ? fildev : NULL,
 341 #ifdef SECURE_INTERNAL_GETENV
 342                           secure ? PERL__TRNENV_SECURE : 0
 343 #else
 344                           0
 345 #endif
 346                                                              );
 347       /* Discard NOLOGNAM on internal calls since we're often looking
 348        * for an optional name, and this "error" often shows up as the
 349        * (bogus) exit status for a die() call later on.  */
 350       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 351       return success ? eqv : Nullch;
 352     }
 353
 354 }  /* end of my_getenv() */
 355 /*}}}*/
 356
 357
 358 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 359 char *
 360 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 361 {
 362     char *buf, *cp1, *cp2;
 363     unsigned long idx = 0;
 364     static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
 365     int secure, saverr, savvmserr;
 366     SV *tmpsv;
 367
 368     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 369       /* Set up a temporary buffer for the return value; Perl will
 370        * clean it up at the next statement transition */
 371       tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
 372       if (!tmpsv) return NULL;
 373       buf = SvPVX(tmpsv);
 374     }
 375     else buf = __my_getenv_len_eqv;  /* Assume no interpreter ==> single thread */
 376     for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 377     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 378       getcwd(buf,LNM$C_NAMLENGTH);
 379       *len = strlen(buf);
 380       return buf;
 381     }
 382     else {
 383       if ((cp2 = strchr(lnm,';')) != NULL) {
 384         strcpy(buf,lnm);
 385         buf[cp2-lnm] = '\0';
 386         idx = strtoul(cp2+1,NULL,0);
 387         lnm = buf;
 388       }
 389       if (sys) {
 390         /* Impose security constraints only if tainting */
 391         secure = PL_curinterp ? PL_tainting : will_taint;
 392         saverr = errno;  savvmserr = vaxc$errno;
 393       }
 394       else secure = 0;
 395       *len = vmstrnenv(lnm,buf,idx,
 396                        secure ? fildev : NULL,
 397 #ifdef SECURE_INTERNAL_GETENV
 398                        secure ? PERL__TRNENV_SECURE : 0
 399 #else
 400                                                       0
 401 #endif
 402                                                        );
 403       /* Discard NOLOGNAM on internal calls since we're often looking
 404        * for an optional name, and this "error" often shows up as the
 405        * (bogus) exit status for a die() call later on.  */
 406       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 407       return *len ? buf : Nullch;
 408     }
 409
 410 }  /* end of my_getenv_len() */
 411 /*}}}*/
 412
 413 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 414
 415 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 416
 417 /*{{{ void prime_env_iter() */
 418 void
 419 prime_env_iter(void)
 420 /* Fill the %ENV associative array with all logical names we can
 421  * find, in preparation for iterating over it.
 422  */
 423 {
 424   static int primed = 0;
 425   HV *seenhv = NULL, *envhv;
 426   SV *sv = NULL;
 427   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 428   unsigned short int chan;
 429 #ifndef CLI$M_TRUSTED
 430 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 431 #endif
 432   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 433   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 434   long int i;
 435   bool have_sym = FALSE, have_lnm = FALSE;
 436   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 437   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 438   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 439   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 440   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 441 #if defined(PERL_IMPLICIT_CONTEXT)
 442   pTHX;
 443 #endif
 444 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
 445   static perl_mutex primenv_mutex;
 446   MUTEX_INIT(&primenv_mutex);
 447 #endif
 448
 449 #if defined(PERL_IMPLICIT_CONTEXT)
 450     /* We jump through these hoops because we can be called at */
 451     /* platform-specific initialization time, which is before anything is */
 452     /* set up--we can't even do a plain dTHX since that relies on the */
 453     /* interpreter structure to be initialized */
 454 #if defined(USE_5005THREADS)
 455     if (PL_curinterp) {
 456       aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
 457     } else {
 458       aTHX = NULL;
 459     }
 460 #else
 461     if (PL_curinterp) {
 462       aTHX = PERL_GET_INTERP;
 463     } else {
 464       aTHX = NULL;
 465     }
 466 #endif
 467 #endif
 468
 469   if (primed || !PL_envgv) return;
 470   MUTEX_LOCK(&primenv_mutex);
 471   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
 472   envhv = GvHVn(PL_envgv);
 473   /* Perform a dummy fetch as an lval to insure that the hash table is
 474    * set up.  Otherwise, the hv_store() will turn into a nullop. */
 475   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
 476
 477   for (i = 0; env_tables[i]; i++) {
 478      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 479          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
 480      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
 481   }
 482   if (have_sym || have_lnm) {
 483     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 484     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 485     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
 486     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
 487   }
 488
 489   for (i--; i >= 0; i--) {
 490     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
 491       char *start;
 492       int j;
 493       for (j = 0; environ[j]; j++) {
 494         if (!(start = strchr(environ[j],'='))) {
 495           if (ckWARN(WARN_INTERNAL))
 496             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
 497         }
 498         else {
 499           start++;
 500           sv = newSVpv(start,0);
 501           SvTAINTED_on(sv);
 502           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
 503         }
 504       }
 505       continue;
 506     }
 507     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 508              !str$case_blind_compare(&tmpdsc,&clisym)) {
 509       strcpy(cmd,"Show Symbol/Global *");
 510       cmddsc.dsc$w_length = 20;
 511       if (env_tables[i]->dsc$w_length == 12 &&
 512           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
 513           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
 514       flags = defflags | CLI$M_NOLOGNAM;
 515     }
 516     else {
 517       strcpy(cmd,"Show Logical *");
 518       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
 519         strcat(cmd," /Table=");
 520         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
 521         cmddsc.dsc$w_length = strlen(cmd);
 522       }
 523       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
 524       flags = defflags | CLI$M_NOCLISYM;
 525     }
 526
 527     /* Create a new subprocess to execute each command, to exclude the
 528      * remote possibility that someone could subvert a mbx or file used
 529      * to write multiple commands to a single subprocess.
 530      */
 531     do {
 532       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
 533                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
 534       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
 535       defflags &= ~CLI$M_TRUSTED;
 536     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
 537     _ckvmssts(retsts);
 538     if (!buf) New(1322,buf,mbxbufsiz + 1,char);
 539     if (seenhv) SvREFCNT_dec(seenhv);
 540     seenhv = newHV();
 541     while (1) {
 542       char *cp1, *cp2, *key;
 543       unsigned long int sts, iosb[2], retlen, keylen;
 544       register U32 hash;
 545
 546       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
 547       if (sts & 1) sts = iosb[0] & 0xffff;
 548       if (sts == SS$_ENDOFFILE) {
 549         int wakect = 0;
 550         while (substs == 0) { sys$hiber(); wakect++;}
 551         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
 552         _ckvmssts(substs);
 553         break;
 554       }
 555       _ckvmssts(sts);
 556       retlen = iosb[0] >> 16;
 557       if (!retlen) continue;  /* blank line */
 558       buf[retlen] = '\0';
 559       if (iosb[1] != subpid) {
 560         if (iosb[1]) {
 561           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
 562         }
 563         continue;
 564       }
 565       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
 566         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
 567
 568       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
 569       if (*cp1 == '(' || /* Logical name table name */
 570           *cp1 == '='    /* Next eqv of searchlist  */) continue;
 571       if (*cp1 == '"') cp1++;
 572       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
 573       key = cp1;  keylen = cp2 - cp1;
 574       if (keylen && hv_exists(seenhv,key,keylen)) continue;
 575       while (*cp2 && *cp2 != '=') cp2++;
 576       while (*cp2 && *cp2 == '=') cp2++;
 577       while (*cp2 && *cp2 == ' ') cp2++;
 578       if (*cp2 == '"') {  /* String translation; may embed "" */
 579         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
 580         cp2++;  cp1--; /* Skip "" surrounding translation */
 581       }
 582       else {  /* Numeric translation */
 583         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
 584         cp1--;  /* stop on last non-space char */
 585       }
 586       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
 587         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
 588         continue;
 589       }
 590       PERL_HASH(hash,key,keylen);
 591       sv = newSVpvn(cp2,cp1 - cp2 + 1);
 592       SvTAINTED_on(sv);
 593       hv_store(envhv,key,keylen,sv,hash);
 594       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
 595     }
 596     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
 597       /* get the PPFs for this process, not the subprocess */
 598       char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
 599       char eqv[LNM$C_NAMLENGTH+1];
 600       int trnlen, i;
 601       for (i = 0; ppfs[i]; i++) {
 602         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
 603         sv = newSVpv(eqv,trnlen);
 604         SvTAINTED_on(sv);
 605         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
 606       }
 607     }
 608   }
 609   primed = 1;
 610   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
 611   if (buf) Safefree(buf);
 612   if (seenhv) SvREFCNT_dec(seenhv);
 613   MUTEX_UNLOCK(&primenv_mutex);
 614   return;
 615
 616 }  /* end of prime_env_iter */
 617 /*}}}*/
 618
 619
 620 /*{{{ int  vmssetenv(char *lnm, char *eqv)*/
 621 /* Define or delete an element in the same "environment" as
 622  * vmstrnenv().  If an element is to be deleted, it's removed from
 623  * the first place it's found.  If it's to be set, it's set in the
 624  * place designated by the first element of the table vector.
 625  * Like setenv() returns 0 for success, non-zero on error.
 626  */
 627 int
 628 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
 629 {
 630     char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
 631     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
 632     unsigned long int retsts, usermode = PSL$C_USER;
 633     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 634                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 635                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 636     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 637     $DESCRIPTOR(local,"_LOCAL");
 638
 639     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 640       *cp2 = _toupper(*cp1);
 641       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 642         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 643         return SS$_IVLOGNAM;
 644       }
 645     }
 646     lnmdsc.dsc$w_length = cp1 - lnm;
 647     if (!tabvec || !*tabvec) tabvec = env_tables;
 648
 649     if (!eqv) {  /* we're deleting n element */
 650       for (curtab = 0; tabvec[curtab]; curtab++) {
 651         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 652         int i;
 653           for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
 654             if ((cp1 = strchr(environ[i],'=')) &&
 655                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
 656 #ifdef HAS_SETENV
 657               return setenv(lnm,"",1) ? vaxc$errno : 0;
 658             }
 659           }
 660           ivenv = 1; retsts = SS$_NOLOGNAM;
 661 #else
 662               if (ckWARN(WARN_INTERNAL))
 663                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
 664               ivenv = 1; retsts = SS$_NOSUCHPGM;
 665               break;
 666             }
 667           }
 668 #endif
 669         }
 670         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 671                  !str$case_blind_compare(&tmpdsc,&clisym)) {
 672           unsigned int symtype;
 673           if (tabvec[curtab]->dsc$w_length == 12 &&
 674               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
 675               !str$case_blind_compare(&tmpdsc,&local))
 676             symtype = LIB$K_CLI_LOCAL_SYM;
 677           else symtype = LIB$K_CLI_GLOBAL_SYM;
 678           retsts = lib$delete_symbol(&lnmdsc,&symtype);
 679           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 680           if (retsts == LIB$_NOSUCHSYM) continue;
 681           break;
 682         }
 683         else if (!ivlnm) {
 684           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
 685           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 686           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 687           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
 688           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 689         }
 690       }
 691     }
 692     else {  /* we're defining a value */
 693       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
 694 #ifdef HAS_SETENV
 695         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 696 #else
 697         if (ckWARN(WARN_INTERNAL))
 698           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
 699         retsts = SS$_NOSUCHPGM;
 700 #endif
 701       }
 702       else {
 703         eqvdsc.dsc$a_pointer = eqv;
 704         eqvdsc.dsc$w_length  = strlen(eqv);
 705         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
 706             !str$case_blind_compare(&tmpdsc,&clisym)) {
 707           unsigned int symtype;
 708           if (tabvec[0]->dsc$w_length == 12 &&
 709               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
 710                !str$case_blind_compare(&tmpdsc,&local))
 711             symtype = LIB$K_CLI_LOCAL_SYM;
 712           else symtype = LIB$K_CLI_GLOBAL_SYM;
 713           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
 714         }
 715         else {
 716           if (!*eqv) eqvdsc.dsc$w_length = 1;
 717           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
 718             eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
 719             if (ckWARN(WARN_MISC)) {
 720               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
 721             }
 722           }
 723           retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
 724         }
 725       }
 726     }
 727     if (!(retsts & 1)) {
 728       switch (retsts) {
 729         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
 730         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
 731           set_errno(EVMSERR); break;
 732         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
 733         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
 734           set_errno(EINVAL); break;
 735         case SS$_NOPRIV:
 736           set_errno(EACCES);
 737         default:
 738           _ckvmssts(retsts);
 739           set_errno(EVMSERR);
 740        }
 741        set_vaxc_errno(retsts);
 742        return (int) retsts || 44; /* retsts should never be 0, but just in case */
 743     }
 744     else {
 745       /* We reset error values on success because Perl does an hv_fetch()
 746        * before each hv_store(), and if the thing we're setting didn't
 747        * previously exist, we've got a leftover error message.  (Of course,
 748        * this fails in the face of
 749        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
 750        * in that the error reported in $! isn't spurious,
 751        * but it's right more often than not.)
 752        */
 753       set_errno(0); set_vaxc_errno(retsts);
 754       return 0;
 755     }
 756
 757 }  /* end of vmssetenv() */
 758 /*}}}*/
 759
 760 /*{{{ void  my_setenv(char *lnm, char *eqv)*/
 761 /* This has to be a function since there's a prototype for it in proto.h */
 762 void
 763 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
 764 {
 765     if (lnm && *lnm) {
 766       int len = strlen(lnm);
 767       if  (len == 7) {
 768         char uplnm[8];
 769         int i;
 770         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
 771         if (!strcmp(uplnm,"DEFAULT")) {
 772           if (eqv && *eqv) chdir(eqv);
 773           return;
 774         }
 775     }
 776 #ifndef RTL_USES_UTC
 777     if (len == 6 || len == 2) {
 778       char uplnm[7];
 779       int i;
 780       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
 781       uplnm[len] = '\0';
 782       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
 783       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
 784     }
 785 #endif
 786   }
 787   (void) vmssetenv(lnm,eqv,NULL);
 788 }
 789 /*}}}*/
 790
 791 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
 792 /*  vmssetuserlnm
 793  *  sets a user-mode logical in the process logical name table
 794  *  used for redirection of sys$error
 795  */
 796 void
 797 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
 798 {
 799     $DESCRIPTOR(d_tab, "LNM$PROCESS");
 800     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 801     unsigned long int iss, attr = LNM$M_CONFINE;
 802     unsigned char acmode = PSL$C_USER;
 803     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
 804                                  {0, 0, 0, 0}};
 805     d_name.dsc$a_pointer = name;
 806     d_name.dsc$w_length = strlen(name);
 807
 808     lnmlst[0].buflen = strlen(eqv);
 809     lnmlst[0].bufadr = eqv;
 810
 811     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
 812     if (!(iss&1)) lib$signal(iss);
 813 }
 814 /*}}}*/
 815
 816
 817 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
 818 /* my_crypt - VMS password hashing
 819  * my_crypt() provides an interface compatible with the Unix crypt()
 820  * C library function, and uses sys$hash_password() to perform VMS
 821  * password hashing.  The quadword hashed password value is returned
 822  * as a NUL-terminated 8 character string.  my_crypt() does not change
 823  * the case of its string arguments; in order to match the behavior
 824  * of LOGINOUT et al., alphabetic characters in both arguments must
 825  *  be upcased by the caller.
 826  */
 827 char *
 828 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
 829 {
 830 #   ifndef UAI$C_PREFERRED_ALGORITHM
 831 #     define UAI$C_PREFERRED_ALGORITHM 127
 832 #   endif
 833     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
 834     unsigned short int salt = 0;
 835     unsigned long int sts;
 836     struct const_dsc {
 837         unsigned short int dsc$w_length;
 838         unsigned char      dsc$b_type;
 839         unsigned char      dsc$b_class;
 840         const char *       dsc$a_pointer;
 841     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
 842        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 843     struct itmlst_3 uailst[3] = {
 844         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
 845         { sizeof salt, UAI$_SALT,    &salt, 0},
 846         { 0,           0,            NULL,  NULL}};
 847     static char hash[9];
 848
 849     usrdsc.dsc$w_length = strlen(usrname);
 850     usrdsc.dsc$a_pointer = usrname;
 851     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
 852       switch (sts) {
 853         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
 854           set_errno(EACCES);
 855           break;
 856         case RMS$_RNF:
 857           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
 858           break;
 859         default:
 860           set_errno(EVMSERR);
 861       }
 862       set_vaxc_errno(sts);
 863       if (sts != RMS$_RNF) return NULL;
 864     }
 865
 866     txtdsc.dsc$w_length = strlen(textpasswd);
 867     txtdsc.dsc$a_pointer = textpasswd;
 868     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
 869       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
 870     }
 871
 872     return (char *) hash;
 873
 874 }  /* end of my_crypt() */
 875 /*}}}*/
 876
 877
 878 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
 879 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
 880 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
 881
 882 /*{{{int do_rmdir(char *name)*/
 883 int
 884 Perl_do_rmdir(pTHX_ char *name)
 885 {
 886     char dirfile[NAM$C_MAXRSS+1];
 887     int retval;
 888     Stat_t st;
 889
 890     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
 891     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
 892     else retval = kill_file(dirfile);
 893     return retval;
 894
 895 }  /* end of do_rmdir */
 896 /*}}}*/
 897
 898 /* kill_file
 899  * Delete any file to which user has control access, regardless of whether
 900  * delete access is explicitly allowed.
 901  * Limitations: User must have write access to parent directory.
 902  *              Does not block signals or ASTs; if interrupted in midstream
 903  *              may leave file with an altered ACL.
 904  * HANDLE WITH CARE!
 905  */
 906 /*{{{int kill_file(char *name)*/
 907 int
 908 Perl_kill_file(pTHX_ char *name)
 909 {
 910     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
 911     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
 912     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
 913     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 914     struct myacedef {
 915       unsigned char myace$b_length;
 916       unsigned char myace$b_type;
 917       unsigned short int myace$w_flags;
 918       unsigned long int myace$l_access;
 919       unsigned long int myace$l_ident;
 920     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
 921                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
 922       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
 923      struct itmlst_3
 924        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
 925                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
 926        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
 927        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
 928        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
 929        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
 930
 931     /* Expand the input spec using RMS, since the CRTL remove() and
 932      * system services won't do this by themselves, so we may miss
 933      * a file "hiding" behind a logical name or search list. */
 934     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
 935     if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
 936     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
 937     /* If not, can changing protections help? */
 938     if (vaxc$errno != RMS$_PRV) return -1;
 939
 940     /* No, so we get our own UIC to use as a rights identifier,
 941      * and the insert an ACE at the head of the ACL which allows us
 942      * to delete the file.
 943      */
 944     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
 945     fildsc.dsc$w_length = strlen(rspec);
 946     fildsc.dsc$a_pointer = rspec;
 947     cxt = 0;
 948     newace.myace$l_ident = oldace.myace$l_ident;
 949     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
 950       switch (aclsts) {
 951         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
 952           set_errno(ENOENT); break;
 953         case RMS$_DIR:
 954           set_errno(ENOTDIR); break;
 955         case RMS$_DEV:
 956           set_errno(ENODEV); break;
 957         case RMS$_SYN: case SS$_INVFILFOROP:
 958           set_errno(EINVAL); break;
 959         case RMS$_PRV:
 960           set_errno(EACCES); break;
 961         default:
 962           _ckvmssts(aclsts);
 963       }
 964       set_vaxc_errno(aclsts);
 965       return -1;
 966     }
 967     /* Grab any existing ACEs with this identifier in case we fail */
 968     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
 969     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
 970                     || fndsts == SS$_NOMOREACE ) {
 971       /* Add the new ACE . . . */
 972       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
 973         goto yourroom;
 974       if ((rmsts = remove(name))) {
 975         /* We blew it - dir with files in it, no write priv for
 976          * parent directory, etc.  Put things back the way they were. */
 977         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
 978           goto yourroom;
 979         if (fndsts & 1) {
 980           addlst[0].bufadr = &oldace;
 981           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
 982             goto yourroom;
 983         }
 984       }
 985     }
 986
 987     yourroom:
 988     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
 989     /* We just deleted it, so of course it's not there.  Some versions of
 990      * VMS seem to return success on the unlock operation anyhow (after all
 991      * the unlock is successful), but others don't.
 992      */
 993     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
 994     if (aclsts & 1) aclsts = fndsts;
 995     if (!(aclsts & 1)) {
 996       set_errno(EVMSERR);
 997       set_vaxc_errno(aclsts);
 998       return -1;
 999     }
1000
1001     return rmsts;
1002
1003 }  /* end of kill_file() */
1004 /*}}}*/
1005
1006
1007 /*{{{int my_mkdir(char *,Mode_t)*/
1008 int
1009 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1010 {
1011   STRLEN dirlen = strlen(dir);
1012
1013   /* zero length string sometimes gives ACCVIO */
1014   if (dirlen == 0) return -1;
1015
1016   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1017    * null file name/type.  However, it's commonplace under Unix,
1018    * so we'll allow it for a gain in portability.
1019    */
1020   if (dir[dirlen-1] == '/') {
1021     char *newdir = savepvn(dir,dirlen-1);
1022     int ret = mkdir(newdir,mode);
1023     Safefree(newdir);
1024     return ret;
1025   }
1026   else return mkdir(dir,mode);
1027 }  /* end of my_mkdir */
1028 /*}}}*/
1029
1030 /*{{{int my_chdir(char *)*/
1031 int
1032 Perl_my_chdir(pTHX_ char *dir)
1033 {
1034   STRLEN dirlen = strlen(dir);
1035
1036   /* zero length string sometimes gives ACCVIO */
1037   if (dirlen == 0) return -1;
1038
1039   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1040    * that implies
1041    * null file name/type.  However, it's commonplace under Unix,
1042    * so we'll allow it for a gain in portability.
1043    */
1044   if (dir[dirlen-1] == '/') {
1045     char *newdir = savepvn(dir,dirlen-1);
1046     int ret = chdir(newdir);
1047     Safefree(newdir);
1048     return ret;
1049   }
1050   else return chdir(dir);
1051 }  /* end of my_chdir */
1052 /*}}}*/
1053
1054
1055 /*{{{FILE *my_tmpfile()*/
1056 FILE *
1057 my_tmpfile(void)
1058 {
1059   FILE *fp;
1060   char *cp;
1061
1062   if ((fp = tmpfile())) return fp;
1063
1064   New(1323,cp,L_tmpnam+24,char);
1065   strcpy(cp,"Sys$Scratch:");
1066   tmpnam(cp+strlen(cp));
1067   strcat(cp,".Perltmp");
1068   fp = fopen(cp,"w+","fop=dlt");
1069   Safefree(cp);
1070   return fp;
1071 }
1072 /*}}}*/
1073
1074
1075 #ifndef HOMEGROWN_POSIX_SIGNALS
1076 /*
1077  * The C RTL's sigaction fails to check for invalid signal numbers so we
1078  * help it out a bit.  The docs are correct, but the actual routine doesn't
1079  * do what the docs say it will.
1080  */
1081 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1082 int
1083 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1084                    struct sigaction* oact)
1085 {
1086   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1087         SETERRNO(EINVAL, SS$_INVARG);
1088         return -1;
1089   }
1090   return sigaction(sig, act, oact);
1091 }
1092 /*}}}*/
1093 #endif
1094
1095 #ifdef KILL_BY_SIGPRC
1096 #include <errnodef.h>
1097
1098 /* We implement our own kill() using the undocumented system service
1099    sys$sigprc for one of two reasons:
1100
1101    1.) If the kill() in an older CRTL uses sys$forcex, causing the
1102    target process to do a sys$exit, which usually can't be handled
1103    gracefully...certainly not by Perl and the %SIG{} mechanism.
1104
1105    2.) If the kill() in the CRTL can't be called from a signal
1106    handler without disappearing into the ether, i.e., the signal
1107    it purportedly sends is never trapped. Still true as of VMS 7.3.
1108
1109    sys$sigprc has the same parameters as sys$forcex, but throws an exception
1110    in the target process rather than calling sys$exit.
1111
1112    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1113    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1114    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
1115    with condition codes C$_SIG0+nsig*8, catching the exception on the
1116    target process and resignaling with appropriate arguments.
1117
1118    But we don't have that VMS 7.0+ exception handler, so if you
1119    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
1120
1121    Also note that SIGTERM is listed in the docs as being "unimplemented",
1122    yet always seems to be signaled with a VMS condition code of 4 (and
1123    correctly handled for that code).  So we hardwire it in.
1124
1125    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1126    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
1127    than signalling with an unrecognized (and unhandled by CRTL) code.
1128 */
1129
1130 #define _MY_SIG_MAX 17
1131
1132 unsigned int
1133 Perl_sig_to_vmscondition(int sig)
1134 {
1135     static unsigned int sig_code[_MY_SIG_MAX+1] =
1136     {
1137         0,                  /*  0 ZERO     */
1138         SS$_HANGUP,         /*  1 SIGHUP   */
1139         SS$_CONTROLC,       /*  2 SIGINT   */
1140         SS$_CONTROLY,       /*  3 SIGQUIT  */
1141         SS$_RADRMOD,        /*  4 SIGILL   */
1142         SS$_BREAK,          /*  5 SIGTRAP  */
1143         SS$_OPCCUS,         /*  6 SIGABRT  */
1144         SS$_COMPAT,         /*  7 SIGEMT   */
1145 #ifdef __VAX
1146         SS$_FLTOVF,         /*  8 SIGFPE VAX */
1147 #else
1148         SS$_HPARITH,        /*  8 SIGFPE AXP */
1149 #endif
1150         SS$_ABORT,          /*  9 SIGKILL  */
1151         SS$_ACCVIO,         /* 10 SIGBUS   */
1152         SS$_ACCVIO,         /* 11 SIGSEGV  */
1153         SS$_BADPARAM,       /* 12 SIGSYS   */
1154         SS$_NOMBX,          /* 13 SIGPIPE  */
1155         SS$_ASTFLT,         /* 14 SIGALRM  */
1156         4,                  /* 15 SIGTERM  */
1157         0,                  /* 16 SIGUSR1  */
1158         0                   /* 17 SIGUSR2  */
1159     };
1160
1161 #if __VMS_VER >= 60200000
1162     static int initted = 0;
1163     if (!initted) {
1164         initted = 1;
1165         sig_code[16] = C$_SIGUSR1;
1166         sig_code[17] = C$_SIGUSR2;
1167     }
1168 #endif
1169
1170     if (sig < _SIG_MIN) return 0;
1171     if (sig > _MY_SIG_MAX) return 0;
1172     return sig_code[sig];
1173 }
1174
1175
1176 int
1177 Perl_my_kill(int pid, int sig)
1178 {
1179     dTHX;
1180     int iss;
1181     unsigned int code;
1182     int sys$sigprc(unsigned int *pidadr,
1183                      struct dsc$descriptor_s *prcname,
1184                      unsigned int code);
1185
1186     code = Perl_sig_to_vmscondition(sig);
1187
1188     if (!pid || !code) {
1189         return -1;
1190     }
1191
1192     iss = sys$sigprc((unsigned int *)&pid,0,code);
1193     if (iss&1) return 0;
1194
1195     switch (iss) {
1196       case SS$_NOPRIV:
1197         set_errno(EPERM);  break;
1198       case SS$_NONEXPR:
1199       case SS$_NOSUCHNODE:
1200       case SS$_UNREACHABLE:
1201         set_errno(ESRCH);  break;
1202       case SS$_INSFMEM:
1203         set_errno(ENOMEM); break;
1204       default:
1205         _ckvmssts(iss);
1206         set_errno(EVMSERR);
1207     }
1208     set_vaxc_errno(iss);
1209
1210     return -1;
1211 }
1212 #endif
1213
1214 /* default piping mailbox size */
1215 #define PERL_BUFSIZ        512
1216
1217
1218 static void
1219 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1220 {
1221   unsigned long int mbxbufsiz;
1222   static unsigned long int syssize = 0;
1223   unsigned long int dviitm = DVI$_DEVNAM;
1224   char csize[LNM$C_NAMLENGTH+1];
1225
1226   if (!syssize) {
1227     unsigned long syiitm = SYI$_MAXBUF;
1228     /*
1229      * Get the SYSGEN parameter MAXBUF
1230      *
1231      * If the logical 'PERL_MBX_SIZE' is defined
1232      * use the value of the logical instead of PERL_BUFSIZ, but
1233      * keep the size between 128 and MAXBUF.
1234      *
1235      */
1236     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1237   }
1238
1239   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1240       mbxbufsiz = atoi(csize);
1241   } else {
1242       mbxbufsiz = PERL_BUFSIZ;
1243   }
1244   if (mbxbufsiz < 128) mbxbufsiz = 128;
1245   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1246
1247   _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1248
1249   _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1250   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1251
1252 }  /* end of create_mbx() */
1253
1254
1255 /*{{{  my_popen and my_pclose*/
1256
1257 typedef struct _iosb           IOSB;
1258 typedef struct _iosb*         pIOSB;
1259 typedef struct _pipe           Pipe;
1260 typedef struct _pipe*         pPipe;
1261 typedef struct pipe_details    Info;
1262 typedef struct pipe_details*  pInfo;
1263 typedef struct _srqp            RQE;
1264 typedef struct _srqp*          pRQE;
1265 typedef struct _tochildbuf      CBuf;
1266 typedef struct _tochildbuf*    pCBuf;
1267
1268 struct _iosb {
1269     unsigned short status;
1270     unsigned short count;
1271     unsigned long  dvispec;
1272 };
1273
1274 #pragma member_alignment save
1275 #pragma nomember_alignment quadword
1276 struct _srqp {          /* VMS self-relative queue entry */
1277     unsigned long qptr[2];
1278 };
1279 #pragma member_alignment restore
1280 static RQE  RQE_ZERO = {0,0};
1281
1282 struct _tochildbuf {
1283     RQE             q;
1284     int             eof;
1285     unsigned short  size;
1286     char            *buf;
1287 };
1288
1289 struct _pipe {
1290     RQE            free;
1291     RQE            wait;
1292     int            fd_out;
1293     unsigned short chan_in;
1294     unsigned short chan_out;
1295     char          *buf;
1296     unsigned int   bufsize;
1297     IOSB           iosb;
1298     IOSB           iosb2;
1299     int           *pipe_done;
1300     int            retry;
1301     int            type;
1302     int            shut_on_empty;
1303     int            need_wake;
1304     pPipe         *home;
1305     pInfo          info;
1306     pCBuf          curr;
1307     pCBuf          curr2;
1308 #if defined(PERL_IMPLICIT_CONTEXT)
1309     void            *thx;           /* Either a thread or an interpreter */
1310                                     /* pointer, depending on how we're built */
1311 #endif
1312 };
1313
1314
1315 struct pipe_details
1316 {
1317     pInfo           next;
1318     PerlIO *fp;  /* file pointer to pipe mailbox */
1319     int useFILE; /* using stdio, not perlio */
1320     int pid;   /* PID of subprocess */
1321     int mode;  /* == 'r' if pipe open for reading */
1322     int done;  /* subprocess has completed */
1323     int waiting; /* waiting for completion/closure */
1324     int             closing;        /* my_pclose is closing this pipe */
1325     unsigned long   completion;     /* termination status of subprocess */
1326     pPipe           in;             /* pipe in to sub */
1327     pPipe           out;            /* pipe out of sub */
1328     pPipe           err;            /* pipe of sub's sys$error */
1329     int             in_done;        /* true when in pipe finished */
1330     int             out_done;
1331     int             err_done;
1332 };
1333
1334 struct exit_control_block
1335 {
1336     struct exit_control_block *flink;
1337     unsigned long int   (*exit_routine)();
1338     unsigned long int arg_count;
1339     unsigned long int *status_address;
1340     unsigned long int exit_status;
1341 };
1342
1343 typedef struct _closed_pipes    Xpipe;
1344 typedef struct _closed_pipes*  pXpipe;
1345
1346 struct _closed_pipes {
1347     int             pid;            /* PID of subprocess */
1348     unsigned long   completion;     /* termination status of subprocess */
1349 };
1350 #define NKEEPCLOSED 50
1351 static Xpipe closed_list[NKEEPCLOSED];
1352 static int   closed_index = 0;
1353 static int   closed_num = 0;
1354
1355 #define RETRY_DELAY     "0 ::0.20"
1356 #define MAX_RETRY              50
1357
1358 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
1359 static unsigned long mypid;
1360 static unsigned long delaytime[2];
1361
1362 static pInfo open_pipes = NULL;
1363 static $DESCRIPTOR(nl_desc, "NL:");
1364
1365 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
1366
1367
1368
1369 static unsigned long int
1370 pipe_exit_routine(pTHX)
1371 {
1372     pInfo info;
1373     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1374     int sts, did_stuff, need_eof, j;
1375
1376     /*
1377         flush any pending i/o
1378     */
1379     info = open_pipes;
1380     while (info) {
1381         if (info->fp) {
1382            if (!info->useFILE)
1383                PerlIO_flush(info->fp);   /* first, flush data */
1384            else
1385                fflush((FILE *)info->fp);
1386         }
1387         info = info->next;
1388     }
1389
1390     /*
1391      next we try sending an EOF...ignore if doesn't work, make sure we
1392      don't hang
1393     */
1394     did_stuff = 0;
1395     info = open_pipes;
1396
1397     while (info) {
1398       int need_eof;
1399       _ckvmssts(sys$setast(0));
1400       if (info->in && !info->in->shut_on_empty) {
1401         _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1402                           0, 0, 0, 0, 0, 0));
1403         info->waiting = 1;
1404         did_stuff = 1;
1405       }
1406       _ckvmssts(sys$setast(1));
1407       info = info->next;
1408     }
1409
1410     /* wait for EOF to have effect, up to ~ 30 sec [default] */
1411
1412     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1413         int nwait = 0;
1414
1415         info = open_pipes;
1416         while (info) {
1417           _ckvmssts(sys$setast(0));
1418           if (info->waiting && info->done)
1419                 info->waiting = 0;
1420           nwait += info->waiting;
1421           _ckvmssts(sys$setast(1));
1422           info = info->next;
1423         }
1424         if (!nwait) break;
1425         sleep(1);
1426     }
1427
1428     did_stuff = 0;
1429     info = open_pipes;
1430     while (info) {
1431       _ckvmssts(sys$setast(0));
1432       if (!info->done) { /* Tap them gently on the shoulder . . .*/
1433         sts = sys$forcex(&info->pid,0,&abort);
1434         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1435         did_stuff = 1;
1436       }
1437       _ckvmssts(sys$setast(1));
1438       info = info->next;
1439     }
1440
1441     /* again, wait for effect */
1442
1443     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1444         int nwait = 0;
1445
1446         info = open_pipes;
1447         while (info) {
1448           _ckvmssts(sys$setast(0));
1449           if (info->waiting && info->done)
1450                 info->waiting = 0;
1451           nwait += info->waiting;
1452           _ckvmssts(sys$setast(1));
1453           info = info->next;
1454         }
1455         if (!nwait) break;
1456         sleep(1);
1457     }
1458
1459     info = open_pipes;
1460     while (info) {
1461       _ckvmssts(sys$setast(0));
1462       if (!info->done) {  /* We tried to be nice . . . */
1463         sts = sys$delprc(&info->pid,0);
1464         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1465       }
1466       _ckvmssts(sys$setast(1));
1467       info = info->next;
1468     }
1469
1470     while(open_pipes) {
1471       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1472       else if (!(sts & 1)) retsts = sts;
1473     }
1474     return retsts;
1475 }
1476
1477 static struct exit_control_block pipe_exitblock =
1478        {(struct exit_control_block *) 0,
1479         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1480
1481 static void pipe_mbxtofd_ast(pPipe p);
1482 static void pipe_tochild1_ast(pPipe p);
1483 static void pipe_tochild2_ast(pPipe p);
1484
1485 static void
1486 popen_completion_ast(pInfo info)
1487 {
1488   pInfo i = open_pipes;
1489   int iss;
1490   pXpipe x;
1491
1492   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1493   closed_list[closed_index].pid = info->pid;
1494   closed_list[closed_index].completion = info->completion;
1495   closed_index++;
1496   if (closed_index == NKEEPCLOSED)
1497     closed_index = 0;
1498   closed_num++;
1499
1500   while (i) {
1501     if (i == info) break;
1502     i = i->next;
1503   }
1504   if (!i) return;       /* unlinked, probably freed too */
1505
1506   info->done = TRUE;
1507
1508 /*
1509     Writing to subprocess ...
1510             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1511
1512             chan_out may be waiting for "done" flag, or hung waiting
1513             for i/o completion to child...cancel the i/o.  This will
1514             put it into "snarf mode" (done but no EOF yet) that discards
1515             input.
1516
1517     Output from subprocess (stdout, stderr) needs to be flushed and
1518     shut down.   We try sending an EOF, but if the mbx is full the pipe
1519     routine should still catch the "shut_on_empty" flag, telling it to
1520     use immediate-style reads so that "mbx empty" -> EOF.
1521
1522
1523 */
1524   if (info->in && !info->in_done) {               /* only for mode=w */
1525         if (info->in->shut_on_empty && info->in->need_wake) {
1526             info->in->need_wake = FALSE;
1527             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1528         } else {
1529             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1530         }
1531   }
1532
1533   if (info->out && !info->out_done) {             /* were we also piping output? */
1534       info->out->shut_on_empty = TRUE;
1535       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1536       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1537       _ckvmssts_noperl(iss);
1538   }
1539
1540   if (info->err && !info->err_done) {        /* we were piping stderr */
1541         info->err->shut_on_empty = TRUE;
1542         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1543         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1544         _ckvmssts_noperl(iss);
1545   }
1546   _ckvmssts_noperl(sys$setef(pipe_ef));
1547
1548 }
1549
1550 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
1551 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
1552
1553 /*
1554     we actually differ from vmstrnenv since we use this to
1555     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1556     are pointing to the same thing
1557 */
1558
1559 static unsigned short
1560 popen_translate(pTHX_ char *logical, char *result)
1561 {
1562     int iss;
1563     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1564     $DESCRIPTOR(d_log,"");
1565     struct _il3 {
1566         unsigned short length;
1567         unsigned short code;
1568         char *         buffer_addr;
1569         unsigned short *retlenaddr;
1570     } itmlst[2];
1571     unsigned short l, ifi;
1572
1573     d_log.dsc$a_pointer = logical;
1574     d_log.dsc$w_length  = strlen(logical);
1575
1576     itmlst[0].code = LNM$_STRING;
1577     itmlst[0].length = 255;
1578     itmlst[0].buffer_addr = result;
1579     itmlst[0].retlenaddr = &l;
1580
1581     itmlst[1].code = 0;
1582     itmlst[1].length = 0;
1583     itmlst[1].buffer_addr = 0;
1584     itmlst[1].retlenaddr = 0;
1585
1586     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1587     if (iss == SS$_NOLOGNAM) {
1588         iss = SS$_NORMAL;
1589         l = 0;
1590     }
1591     if (!(iss&1)) lib$signal(iss);
1592     result[l] = '\0';
1593 /*
1594     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
1595     strip it off and return the ifi, if any
1596 */
1597     ifi  = 0;
1598     if (result[0] == 0x1b && result[1] == 0x00) {
1599         memcpy(&ifi,result+2,2);
1600         strcpy(result,result+4);
1601     }
1602     return ifi;     /* this is the RMS internal file id */
1603 }
1604
1605 static void pipe_infromchild_ast(pPipe p);
1606
1607 /*
1608     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1609     inside an AST routine without worrying about reentrancy and which Perl
1610     memory allocator is being used.
1611
1612     We read data and queue up the buffers, then spit them out one at a
1613     time to the output mailbox when the output mailbox is ready for one.
1614
1615 */
1616 #define INITIAL_TOCHILDQUEUE  2
1617
1618 static pPipe
1619 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1620 {
1621     pPipe p;
1622     pCBuf b;
1623     char mbx1[64], mbx2[64];
1624     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1625                                       DSC$K_CLASS_S, mbx1},
1626                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1627                                       DSC$K_CLASS_S, mbx2};
1628     unsigned int dviitm = DVI$_DEVBUFSIZ;
1629     int j, n;
1630
1631     New(1368, p, 1, Pipe);
1632
1633     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1634     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1635     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1636
1637     p->buf           = 0;
1638     p->shut_on_empty = FALSE;
1639     p->need_wake     = FALSE;
1640     p->type          = 0;
1641     p->retry         = 0;
1642     p->iosb.status   = SS$_NORMAL;
1643     p->iosb2.status  = SS$_NORMAL;
1644     p->free          = RQE_ZERO;
1645     p->wait          = RQE_ZERO;
1646     p->curr          = 0;
1647     p->curr2         = 0;
1648     p->info          = 0;
1649 #ifdef PERL_IMPLICIT_CONTEXT
1650     p->thx           = aTHX;
1651 #endif
1652
1653     n = sizeof(CBuf) + p->bufsize;
1654
1655     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1656         _ckvmssts(lib$get_vm(&n, &b));
1657         b->buf = (char *) b + sizeof(CBuf);
1658         _ckvmssts(lib$insqhi(b, &p->free));
1659     }
1660
1661     pipe_tochild2_ast(p);
1662     pipe_tochild1_ast(p);
1663     strcpy(wmbx, mbx1);
1664     strcpy(rmbx, mbx2);
1665     return p;
1666 }
1667
1668 /*  reads the MBX Perl is writing, and queues */
1669
1670 static void
1671 pipe_tochild1_ast(pPipe p)
1672 {
1673     pCBuf b = p->curr;
1674     int iss = p->iosb.status;
1675     int eof = (iss == SS$_ENDOFFILE);
1676 #ifdef PERL_IMPLICIT_CONTEXT
1677     pTHX = p->thx;
1678 #endif
1679
1680     if (p->retry) {
1681         if (eof) {
1682             p->shut_on_empty = TRUE;
1683             b->eof     = TRUE;
1684             _ckvmssts(sys$dassgn(p->chan_in));
1685         } else  {
1686             _ckvmssts(iss);
1687         }
1688
1689         b->eof  = eof;
1690         b->size = p->iosb.count;
1691         _ckvmssts(lib$insqhi(b, &p->wait));
1692         if (p->need_wake) {
1693             p->need_wake = FALSE;
1694             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1695         }
1696     } else {
1697         p->retry = 1;   /* initial call */
1698     }
1699
1700     if (eof) {                  /* flush the free queue, return when done */
1701         int n = sizeof(CBuf) + p->bufsize;
1702         while (1) {
1703             iss = lib$remqti(&p->free, &b);
1704             if (iss == LIB$_QUEWASEMP) return;
1705             _ckvmssts(iss);
1706             _ckvmssts(lib$free_vm(&n, &b));
1707         }
1708     }
1709
1710     iss = lib$remqti(&p->free, &b);
1711     if (iss == LIB$_QUEWASEMP) {
1712         int n = sizeof(CBuf) + p->bufsize;
1713         _ckvmssts(lib$get_vm(&n, &b));
1714         b->buf = (char *) b + sizeof(CBuf);
1715     } else {
1716        _ckvmssts(iss);
1717     }
1718
1719     p->curr = b;
1720     iss = sys$qio(0,p->chan_in,
1721              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1722              &p->iosb,
1723              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1724     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1725     _ckvmssts(iss);
1726 }
1727
1728
1729 /* writes queued buffers to output, waits for each to complete before
1730    doing the next */
1731
1732 static void
1733 pipe_tochild2_ast(pPipe p)
1734 {
1735     pCBuf b = p->curr2;
1736     int iss = p->iosb2.status;
1737     int n = sizeof(CBuf) + p->bufsize;
1738     int done = (p->info && p->info->done) ||
1739               iss == SS$_CANCEL || iss == SS$_ABORT;
1740 #if defined(PERL_IMPLICIT_CONTEXT)
1741     pTHX = p->thx;
1742 #endif
1743
1744     do {
1745         if (p->type) {         /* type=1 has old buffer, dispose */
1746             if (p->shut_on_empty) {
1747                 _ckvmssts(lib$free_vm(&n, &b));
1748             } else {
1749                 _ckvmssts(lib$insqhi(b, &p->free));
1750             }
1751             p->type = 0;
1752         }
1753
1754         iss = lib$remqti(&p->wait, &b);
1755         if (iss == LIB$_QUEWASEMP) {
1756             if (p->shut_on_empty) {
1757                 if (done) {
1758                     _ckvmssts(sys$dassgn(p->chan_out));
1759                     *p->pipe_done = TRUE;
1760                     _ckvmssts(sys$setef(pipe_ef));
1761                 } else {
1762                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1763                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1764                 }
1765                 return;
1766             }
1767             p->need_wake = TRUE;
1768             return;
1769         }
1770         _ckvmssts(iss);
1771         p->type = 1;
1772     } while (done);
1773
1774
1775     p->curr2 = b;
1776     if (b->eof) {
1777         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1778             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1779     } else {
1780         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1781             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1782     }
1783
1784     return;
1785
1786 }
1787
1788
1789 static pPipe
1790 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1791 {
1792     pPipe p;
1793     char mbx1[64], mbx2[64];
1794     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1795                                       DSC$K_CLASS_S, mbx1},
1796                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1797                                       DSC$K_CLASS_S, mbx2};
1798     unsigned int dviitm = DVI$_DEVBUFSIZ;
1799
1800     New(1367, p, 1, Pipe);
1801     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1802     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1803
1804     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1805     New(1367, p->buf, p->bufsize, char);
1806     p->shut_on_empty = FALSE;
1807     p->info   = 0;
1808     p->type   = 0;
1809     p->iosb.status = SS$_NORMAL;
1810 #if defined(PERL_IMPLICIT_CONTEXT)
1811     p->thx = aTHX;
1812 #endif
1813     pipe_infromchild_ast(p);
1814
1815     strcpy(wmbx, mbx1);
1816     strcpy(rmbx, mbx2);
1817     return p;
1818 }
1819
1820 static void
1821 pipe_infromchild_ast(pPipe p)
1822 {
1823     int iss = p->iosb.status;
1824     int eof = (iss == SS$_ENDOFFILE);
1825     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1826     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1827 #if defined(PERL_IMPLICIT_CONTEXT)
1828     pTHX = p->thx;
1829 #endif
1830
1831     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
1832         _ckvmssts(sys$dassgn(p->chan_out));
1833         p->chan_out = 0;
1834     }
1835
1836     /* read completed:
1837             input shutdown if EOF from self (done or shut_on_empty)
1838             output shutdown if closing flag set (my_pclose)
1839             send data/eof from child or eof from self
1840             otherwise, re-read (snarf of data from child)
1841     */
1842
1843     if (p->type == 1) {
1844         p->type = 0;
1845         if (myeof && p->chan_in) {                  /* input shutdown */
1846             _ckvmssts(sys$dassgn(p->chan_in));
1847             p->chan_in = 0;
1848         }
1849
1850         if (p->chan_out) {
1851             if (myeof || kideof) {      /* pass EOF to parent */
1852                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1853                               pipe_infromchild_ast, p,
1854                               0, 0, 0, 0, 0, 0));
1855                 return;
1856             } else if (eof) {       /* eat EOF --- fall through to read*/
1857
1858             } else {                /* transmit data */
1859                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1860                               pipe_infromchild_ast,p,
1861                               p->buf, p->iosb.count, 0, 0, 0, 0));
1862                 return;
1863             }
1864         }
1865     }
1866
1867     /*  everything shut? flag as done */
1868
1869     if (!p->chan_in && !p->chan_out) {
1870         *p->pipe_done = TRUE;
1871         _ckvmssts(sys$setef(pipe_ef));
1872         return;
1873     }
1874
1875     /* write completed (or read, if snarfing from child)
1876             if still have input active,
1877                queue read...immediate mode if shut_on_empty so we get EOF if empty
1878             otherwise,
1879                check if Perl reading, generate EOFs as needed
1880     */
1881
1882     if (p->type == 0) {
1883         p->type = 1;
1884         if (p->chan_in) {
1885             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1886                           pipe_infromchild_ast,p,
1887                           p->buf, p->bufsize, 0, 0, 0, 0);
1888             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1889             _ckvmssts(iss);
1890         } else {           /* send EOFs for extra reads */
1891             p->iosb.status = SS$_ENDOFFILE;
1892             p->iosb.dvispec = 0;
1893             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1894                       0, 0, 0,
1895                       pipe_infromchild_ast, p, 0, 0, 0, 0));
1896         }
1897     }
1898 }
1899
1900 static pPipe
1901 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1902 {
1903     pPipe p;
1904     char mbx[64];
1905     unsigned long dviitm = DVI$_DEVBUFSIZ;
1906     struct stat s;
1907     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1908                                       DSC$K_CLASS_S, mbx};
1909
1910     /* things like terminals and mbx's don't need this filter */
1911     if (fd && fstat(fd,&s) == 0) {
1912         unsigned long dviitm = DVI$_DEVCHAR, devchar;
1913         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1914                                          DSC$K_CLASS_S, s.st_dev};
1915
1916         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1917         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
1918             strcpy(out, s.st_dev);
1919             return 0;
1920         }
1921     }
1922
1923     New(1366, p, 1, Pipe);
1924     p->fd_out = dup(fd);
1925     create_mbx(aTHX_ &p->chan_in, &d_mbx);
1926     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1927     New(1366, p->buf, p->bufsize+1, char);
1928     p->shut_on_empty = FALSE;
1929     p->retry = 0;
1930     p->info  = 0;
1931     strcpy(out, mbx);
1932
1933     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1934                   pipe_mbxtofd_ast, p,
1935                   p->buf, p->bufsize, 0, 0, 0, 0));
1936
1937     return p;
1938 }
1939
1940 static void
1941 pipe_mbxtofd_ast(pPipe p)
1942 {
1943     int iss = p->iosb.status;
1944     int done = p->info->done;
1945     int iss2;
1946     int eof = (iss == SS$_ENDOFFILE);
1947     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1948     int err = !(iss&1) && !eof;
1949 #if defined(PERL_IMPLICIT_CONTEXT)
1950     pTHX = p->thx;
1951 #endif
1952
1953     if (done && myeof) {               /* end piping */
1954         close(p->fd_out);
1955         sys$dassgn(p->chan_in);
1956         *p->pipe_done = TRUE;
1957         _ckvmssts(sys$setef(pipe_ef));
1958         return;
1959     }
1960
1961     if (!err && !eof) {             /* good data to send to file */
1962         p->buf[p->iosb.count] = '\n';
1963         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1964         if (iss2 < 0) {
1965             p->retry++;
1966             if (p->retry < MAX_RETRY) {
1967                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1968                 return;
1969             }
1970         }
1971         p->retry = 0;
1972     } else if (err) {
1973         _ckvmssts(iss);
1974     }
1975
1976
1977     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1978           pipe_mbxtofd_ast, p,
1979           p->buf, p->bufsize, 0, 0, 0, 0);
1980     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1981     _ckvmssts(iss);
1982 }
1983
1984
1985 typedef struct _pipeloc     PLOC;
1986 typedef struct _pipeloc*   pPLOC;
1987
1988 struct _pipeloc {
1989     pPLOC   next;
1990     char    dir[NAM$C_MAXRSS+1];
1991 };
1992 static pPLOC  head_PLOC = 0;
1993
1994 void
1995 free_pipelocs(pTHX_ void *head)
1996 {
1997     pPLOC p, pnext;
1998     pPLOC *pHead = (pPLOC *)head;
1999
2000     p = *pHead;
2001     while (p) {
2002         pnext = p->next;
2003         Safefree(p);
2004         p = pnext;
2005     }
2006     *pHead = 0;
2007 }
2008
2009 static void
2010 store_pipelocs(pTHX)
2011 {
2012     int    i;
2013     pPLOC  p;
2014     AV    *av = 0;
2015     SV    *dirsv;
2016     GV    *gv;
2017     char  *dir, *x;
2018     char  *unixdir;
2019     char  temp[NAM$C_MAXRSS+1];
2020     STRLEN n_a;
2021
2022     if (head_PLOC)
2023         free_pipelocs(aTHX_ &head_PLOC);
2024
2025 /*  the . directory from @INC comes last */
2026
2027     New(1370,p,1,PLOC);
2028     p->next = head_PLOC;
2029     head_PLOC = p;
2030     strcpy(p->dir,"./");
2031
2032 /*  get the directory from $^X */
2033
2034 #ifdef PERL_IMPLICIT_CONTEXT
2035     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2036 #else
2037     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2038 #endif
2039         strcpy(temp, PL_origargv[0]);
2040         x = strrchr(temp,']');
2041         if (x) x[1] = '\0';
2042
2043         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2044             New(1370,p,1,PLOC);
2045             p->next = head_PLOC;
2046             head_PLOC = p;
2047             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2048             p->dir[NAM$C_MAXRSS] = '\0';
2049         }
2050     }
2051
2052 /*  reverse order of @INC entries, skip "." since entered above */
2053
2054 #ifdef PERL_IMPLICIT_CONTEXT
2055     if (aTHX)
2056 #endif
2057     if (PL_incgv) av = GvAVn(PL_incgv);
2058
2059     for (i = 0; av && i <= AvFILL(av); i++) {
2060         dirsv = *av_fetch(av,i,TRUE);
2061
2062         if (SvROK(dirsv)) continue;
2063         dir = SvPVx(dirsv,n_a);
2064         if (strcmp(dir,".") == 0) continue;
2065         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2066             continue;
2067
2068         New(1370,p,1,PLOC);
2069         p->next = head_PLOC;
2070         head_PLOC = p;
2071         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2072         p->dir[NAM$C_MAXRSS] = '\0';
2073     }
2074
2075 /* most likely spot (ARCHLIB) put first in the list */
2076
2077 #ifdef ARCHLIB_EXP
2078     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2079         New(1370,p,1,PLOC);
2080         p->next = head_PLOC;
2081         head_PLOC = p;
2082         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2083         p->dir[NAM$C_MAXRSS] = '\0';
2084     }
2085 #endif
2086 }
2087
2088
2089 static char *
2090 find_vmspipe(pTHX)
2091 {
2092     static int   vmspipe_file_status = 0;
2093     static char  vmspipe_file[NAM$C_MAXRSS+1];
2094
2095     /* already found? Check and use ... need read+execute permission */
2096
2097     if (vmspipe_file_status == 1) {
2098         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2099          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2100             return vmspipe_file;
2101         }
2102         vmspipe_file_status = 0;
2103     }
2104
2105     /* scan through stored @INC, $^X */
2106
2107     if (vmspipe_file_status == 0) {
2108         char file[NAM$C_MAXRSS+1];
2109         pPLOC  p = head_PLOC;
2110
2111         while (p) {
2112             strcpy(file, p->dir);
2113             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2114             file[NAM$C_MAXRSS] = '\0';
2115             p = p->next;
2116
2117             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2118
2119             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2120              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2121                 vmspipe_file_status = 1;
2122                 return vmspipe_file;
2123             }
2124         }
2125         vmspipe_file_status = -1;   /* failed, use tempfiles */
2126     }
2127
2128     return 0;
2129 }
2130
2131 static FILE *
2132 vmspipe_tempfile(pTHX)
2133 {
2134     char file[NAM$C_MAXRSS+1];
2135     FILE *fp;
2136     static int index = 0;
2137     stat_t s0, s1;
2138
2139     /* create a tempfile */
2140
2141     /* we can't go from   W, shr=get to  R, shr=get without
2142        an intermediate vulnerable state, so don't bother trying...
2143
2144        and lib$spawn doesn't shr=put, so have to close the write
2145
2146        So... match up the creation date/time and the FID to
2147        make sure we're dealing with the same file
2148
2149     */
2150
2151     index++;
2152     sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2153     fp = fopen(file,"w");
2154     if (!fp) {
2155         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2156         fp = fopen(file,"w");
2157         if (!fp) {
2158             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2159             fp = fopen(file,"w");
2160         }
2161     }
2162     if (!fp) return 0;  /* we're hosed */
2163
2164     fprintf(fp,"$! 'f$verify(0)\n");
2165     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
2166     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
2167     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2168     fprintf(fp,"$ perl_on     = \"set noon\"\n");
2169     fprintf(fp,"$ perl_exit   = \"exit\"\n");
2170     fprintf(fp,"$ perl_del    = \"delete\"\n");
2171     fprintf(fp,"$ pif         = \"if\"\n");
2172     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
2173     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
2174     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
2175     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
2176     fprintf(fp,"$!  --- build command line to get max possible length\n");
2177     fprintf(fp,"$c=perl_popen_cmd0\n");
2178     fprintf(fp,"$c=c+perl_popen_cmd1\n");
2179     fprintf(fp,"$c=c+perl_popen_cmd2\n");
2180     fprintf(fp,"$x=perl_popen_cmd3\n");
2181     fprintf(fp,"$c=c+x\n");
2182     fprintf(fp,"$!  --- get rid of global symbols\n");
2183     fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
2184     fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
2185     fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
2186     fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd0\n");
2187     fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd1\n");
2188     fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd2\n");
2189     fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd3\n");
2190     fprintf(fp,"$ perl_on\n");
2191     fprintf(fp,"$ 'c\n");
2192     fprintf(fp,"$ perl_status = $STATUS\n");
2193     fprintf(fp,"$ perl_del  'perl_cfile'\n");
2194     fprintf(fp,"$ perl_exit 'perl_status'\n");
2195     fsync(fileno(fp));
2196
2197     fgetname(fp, file, 1);
2198     fstat(fileno(fp), &s0);
2199     fclose(fp);
2200
2201     fp = fopen(file,"r","shr=get");
2202     if (!fp) return 0;
2203     fstat(fileno(fp), &s1);
2204
2205     if (s0.st_ino[0] != s1.st_ino[0] ||
2206         s0.st_ino[1] != s1.st_ino[1] ||
2207         s0.st_ino[2] != s1.st_ino[2] ||
2208         s0.st_ctime  != s1.st_ctime  )  {
2209         fclose(fp);
2210         return 0;
2211     }
2212
2213     return fp;
2214 }
2215
2216
2217
2218 static PerlIO *
2219 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2220 {
2221     static int handler_set_up = FALSE;
2222     unsigned long int sts, flags = CLI$M_NOWAIT;
2223     unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2224     int j, wait = 0;
2225     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2226     char in[512], out[512], err[512], mbx[512];
2227     FILE *tpipe = 0;
2228     char tfilebuf[NAM$C_MAXRSS+1];
2229     pInfo info;
2230     char cmd_sym_name[20];
2231     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2232                                       DSC$K_CLASS_S, symbol};
2233     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2234                                       DSC$K_CLASS_S, 0};
2235     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2236                                       DSC$K_CLASS_S, cmd_sym_name};
2237     struct dsc$descriptor_s *vmscmd;
2238     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2239     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2240     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2241
2242     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
2243
2244     /* once-per-program initialization...
2245        note that the SETAST calls and the dual test of pipe_ef
2246        makes sure that only the FIRST thread through here does
2247        the initialization...all other threads wait until it's
2248        done.
2249
2250        Yeah, uglier than a pthread call, it's got all the stuff inline
2251        rather than in a separate routine.
2252     */
2253
2254     if (!pipe_ef) {
2255         _ckvmssts(sys$setast(0));
2256         if (!pipe_ef) {
2257             unsigned long int pidcode = JPI$_PID;
2258             $DESCRIPTOR(d_delay, RETRY_DELAY);
2259             _ckvmssts(lib$get_ef(&pipe_ef));
2260             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2261             _ckvmssts(sys$bintim(&d_delay, delaytime));
2262         }
2263         if (!handler_set_up) {
2264           _ckvmssts(sys$dclexh(&pipe_exitblock));
2265           handler_set_up = TRUE;
2266         }
2267         _ckvmssts(sys$setast(1));
2268     }
2269
2270     /* see if we can find a VMSPIPE.COM */
2271
2272     tfilebuf[0] = '@';
2273     vmspipe = find_vmspipe(aTHX);
2274     if (vmspipe) {
2275         strcpy(tfilebuf+1,vmspipe);
2276     } else {        /* uh, oh...we're in tempfile hell */
2277         tpipe = vmspipe_tempfile(aTHX);
2278         if (!tpipe) {       /* a fish popular in Boston */
2279             if (ckWARN(WARN_PIPE)) {
2280                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
2281             }
2282         return Nullfp;
2283         }
2284         fgetname(tpipe,tfilebuf+1,1);
2285     }
2286     vmspipedsc.dsc$a_pointer = tfilebuf;
2287     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
2288
2289     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
2290     if (!(sts & 1)) {
2291       switch (sts) {
2292         case RMS$_FNF:  case RMS$_DNF:
2293           set_errno(ENOENT); break;
2294         case RMS$_DIR:
2295           set_errno(ENOTDIR); break;
2296         case RMS$_DEV:
2297           set_errno(ENODEV); break;
2298         case RMS$_PRV:
2299           set_errno(EACCES); break;
2300         case RMS$_SYN:
2301           set_errno(EINVAL); break;
2302         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2303           set_errno(E2BIG); break;
2304         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2305           _ckvmssts(sts); /* fall through */
2306         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2307           set_errno(EVMSERR);
2308       }
2309       set_vaxc_errno(sts);
2310       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2311         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2312       }
2313       *psts = sts;
2314       return Nullfp;
2315     }
2316     New(1301,info,1,Info);
2317
2318     strcpy(mode,in_mode);
2319     info->mode = *mode;
2320     info->done = FALSE;
2321     info->completion = 0;
2322     info->closing    = FALSE;
2323     info->in         = 0;
2324     info->out        = 0;
2325     info->err        = 0;
2326     info->fp         = Nullfp;
2327     info->useFILE    = 0;
2328     info->waiting    = 0;
2329     info->in_done    = TRUE;
2330     info->out_done   = TRUE;
2331     info->err_done   = TRUE;
2332     in[0] = out[0] = err[0] = '\0';
2333
2334     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
2335         info->useFILE = 1;
2336         strcpy(p,p+1);
2337     }
2338     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
2339         wait = 1;
2340         strcpy(p,p+1);
2341     }
2342
2343     if (*mode == 'r') {             /* piping from subroutine */
2344
2345         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2346         if (info->out) {
2347             info->out->pipe_done = &info->out_done;
2348             info->out_done = FALSE;
2349             info->out->info = info;
2350         }
2351         if (!info->useFILE) {
2352         info->fp  = PerlIO_open(mbx, mode);
2353         } else {
2354             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2355             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2356         }
2357
2358         if (!info->fp && info->out) {
2359             sys$cancel(info->out->chan_out);
2360
2361             while (!info->out_done) {
2362                 int done;
2363                 _ckvmssts(sys$setast(0));
2364                 done = info->out_done;
2365                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2366                 _ckvmssts(sys$setast(1));
2367                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2368             }
2369
2370             if (info->out->buf) Safefree(info->out->buf);
2371             Safefree(info->out);
2372             Safefree(info);
2373             *psts = RMS$_FNF;
2374             return Nullfp;
2375         }
2376
2377         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2378         if (info->err) {
2379             info->err->pipe_done = &info->err_done;
2380             info->err_done = FALSE;
2381             info->err->info = info;
2382         }
2383
2384     } else if (*mode == 'w') {      /* piping to subroutine */
2385
2386         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2387         if (info->out) {
2388             info->out->pipe_done = &info->out_done;
2389             info->out_done = FALSE;
2390             info->out->info = info;
2391         }
2392
2393         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2394         if (info->err) {
2395             info->err->pipe_done = &info->err_done;
2396             info->err_done = FALSE;
2397             info->err->info = info;
2398         }
2399
2400         info->in = pipe_tochild_setup(aTHX_ in,mbx);
2401         if (!info->useFILE) {
2402         info->fp  = PerlIO_open(mbx, mode);
2403         } else {
2404             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2405             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2406         }
2407
2408         if (info->in) {
2409             info->in->pipe_done = &info->in_done;
2410             info->in_done = FALSE;
2411             info->in->info = info;
2412         }
2413
2414         /* error cleanup */
2415         if (!info->fp && info->in) {
2416             info->done = TRUE;
2417             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2418                               0, 0, 0, 0, 0, 0, 0, 0));
2419
2420             while (!info->in_done) {
2421                 int done;
2422                 _ckvmssts(sys$setast(0));
2423                 done = info->in_done;
2424                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2425                 _ckvmssts(sys$setast(1));
2426                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2427             }
2428
2429             if (info->in->buf) Safefree(info->in->buf);
2430             Safefree(info->in);
2431             Safefree(info);
2432             *psts = RMS$_FNF;
2433             return Nullfp;
2434         }
2435
2436
2437     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
2438         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2439         if (info->out) {
2440             info->out->pipe_done = &info->out_done;
2441             info->out_done = FALSE;
2442             info->out->info = info;
2443         }
2444
2445         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2446         if (info->err) {
2447             info->err->pipe_done = &info->err_done;
2448             info->err_done = FALSE;
2449             info->err->info = info;
2450         }
2451     }
2452
2453     symbol[MAX_DCL_SYMBOL] = '\0';
2454
2455     strncpy(symbol, in, MAX_DCL_SYMBOL);
2456     d_symbol.dsc$w_length = strlen(symbol);
2457     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2458
2459     strncpy(symbol, err, MAX_DCL_SYMBOL);
2460     d_symbol.dsc$w_length = strlen(symbol);
2461     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2462
2463     strncpy(symbol, out, MAX_DCL_SYMBOL);
2464     d_symbol.dsc$w_length = strlen(symbol);
2465     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2466
2467     p = vmscmd->dsc$a_pointer;
2468     while (*p && *p != '\n') p++;
2469     *p = '\0';                                  /* truncate on \n */
2470     p = vmscmd->dsc$a_pointer;
2471     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
2472     if (*p == '$') p++;                         /* remove leading $ */
2473     while (*p == ' ' || *p == '\t') p++;
2474
2475     for (j = 0; j < 4; j++) {
2476         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2477         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2478
2479     strncpy(symbol, p, MAX_DCL_SYMBOL);
2480     d_symbol.dsc$w_length = strlen(symbol);
2481     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2482
2483         if (strlen(p) > MAX_DCL_SYMBOL) {
2484             p += MAX_DCL_SYMBOL;
2485         } else {
2486             p += strlen(p);
2487         }
2488     }
2489     _ckvmssts(sys$setast(0));
2490     info->next=open_pipes;  /* prepend to list */
2491     open_pipes=info;
2492     _ckvmssts(sys$setast(1));
2493     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
2494      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
2495      * have SYS$COMMAND if we need it.
2496      */
2497     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
2498                       0, &info->pid, &info->completion,
2499                       0, popen_completion_ast,info,0,0,0));
2500
2501     /* if we were using a tempfile, close it now */
2502
2503     if (tpipe) fclose(tpipe);
2504
2505     /* once the subprocess is spawned, it has copied the symbols and
2506        we can get rid of ours */
2507
2508     for (j = 0; j < 4; j++) {
2509         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2510         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2511     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2512     }
2513     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
2514     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2515     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2516     vms_execfree(vmscmd);
2517
2518 #ifdef PERL_IMPLICIT_CONTEXT
2519     if (aTHX)
2520 #endif
2521     PL_forkprocess = info->pid;
2522
2523     if (wait) {
2524          int done = 0;
2525          while (!done) {
2526              _ckvmssts(sys$setast(0));
2527              done = info->done;
2528              if (!done) _ckvmssts(sys$clref(pipe_ef));
2529              _ckvmssts(sys$setast(1));
2530              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2531          }
2532         *psts = info->completion;
2533         my_pclose(info->fp);
2534     } else {
2535         *psts = SS$_NORMAL;
2536     }
2537     return info->fp;
2538 }  /* end of safe_popen */
2539
2540
2541 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
2542 PerlIO *
2543 Perl_my_popen(pTHX_ char *cmd, char *mode)
2544 {
2545     int sts;
2546     TAINT_ENV();
2547     TAINT_PROPER("popen");
2548     PERL_FLUSHALL_FOR_CHILD;
2549     return safe_popen(aTHX_ cmd,mode,&sts);
2550 }
2551
2552 /*}}}*/
2553
2554 /*{{{  I32 my_pclose(PerlIO *fp)*/
2555 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2556 {
2557     pInfo info, last = NULL;
2558     unsigned long int retsts;
2559     int done, iss;
2560
2561     for (info = open_pipes; info != NULL; last = info, info = info->next)
2562         if (info->fp == fp) break;
2563
2564     if (info == NULL) {  /* no such pipe open */
2565       set_errno(ECHILD); /* quoth POSIX */
2566       set_vaxc_errno(SS$_NONEXPR);
2567       return -1;
2568     }
2569
2570     /* If we were writing to a subprocess, insure that someone reading from
2571      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
2572      * produce an EOF record in the mailbox.
2573      *
2574      *  well, at least sometimes it *does*, so we have to watch out for
2575      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
2576      */
2577      if (info->fp) {
2578         if (!info->useFILE)
2579      PerlIO_flush(info->fp);   /* first, flush data */
2580         else
2581             fflush((FILE *)info->fp);
2582     }
2583
2584     _ckvmssts(sys$setast(0));
2585      info->closing = TRUE;
2586      done = info->done && info->in_done && info->out_done && info->err_done;
2587      /* hanging on write to Perl's input? cancel it */
2588      if (info->mode == 'r' && info->out && !info->out_done) {
2589         if (info->out->chan_out) {
2590             _ckvmssts(sys$cancel(info->out->chan_out));
2591             if (!info->out->chan_in) {   /* EOF generation, need AST */
2592                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2593             }
2594         }
2595      }
2596      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
2597          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2598                            0, 0, 0, 0, 0, 0));
2599     _ckvmssts(sys$setast(1));
2600     if (info->fp) {
2601      if (!info->useFILE)
2602     PerlIO_close(info->fp);
2603      else
2604         fclose((FILE *)info->fp);
2605     }
2606      /*
2607         we have to wait until subprocess completes, but ALSO wait until all
2608         the i/o completes...otherwise we'll be freeing the "info" structure
2609         that the i/o ASTs could still be using...
2610      */
2611
2612      while (!done) {
2613          _ckvmssts(sys$setast(0));
2614          done = info->done && info->in_done && info->out_done && info->err_done;
2615          if (!done) _ckvmssts(sys$clref(pipe_ef));
2616          _ckvmssts(sys$setast(1));
2617          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2618      }
2619      retsts = info->completion;
2620
2621     /* remove from list of open pipes */
2622     _ckvmssts(sys$setast(0));
2623     if (last) last->next = info->next;
2624     else open_pipes = info->next;
2625     _ckvmssts(sys$setast(1));
2626
2627     /* free buffers and structures */
2628
2629     if (info->in) {
2630         if (info->in->buf) Safefree(info->in->buf);
2631         Safefree(info->in);
2632     }
2633     if (info->out) {
2634         if (info->out->buf) Safefree(info->out->buf);
2635         Safefree(info->out);
2636     }
2637     if (info->err) {
2638         if (info->err->buf) Safefree(info->err->buf);
2639         Safefree(info->err);
2640     }
2641     Safefree(info);
2642
2643     return retsts;
2644
2645 }  /* end of my_pclose() */
2646
2647 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2648   /* Roll our own prototype because we want this regardless of whether
2649    * _VMS_WAIT is defined.
2650    */
2651   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2652 #endif
2653 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2654    created with popen(); otherwise partially emulate waitpid() unless
2655    we have a suitable one from the CRTL that came with VMS 7.2 and later.
2656    Also check processes not considered by the CRTL waitpid().
2657  */
2658 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2659 Pid_t
2660 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2661 {
2662     pInfo info;
2663     int done;
2664     int sts;
2665     int j;
2666
2667     if (statusp) *statusp = 0;
2668
2669     for (info = open_pipes; info != NULL; info = info->next)
2670         if (info->pid == pid) break;
2671
2672     if (info != NULL) {  /* we know about this child */
2673       while (!info->done) {
2674           _ckvmssts(sys$setast(0));
2675           done = info->done;
2676           if (!done) _ckvmssts(sys$clref(pipe_ef));
2677           _ckvmssts(sys$setast(1));
2678           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2679       }
2680
2681       if (statusp) *statusp = info->completion;
2682       return pid;
2683     }
2684
2685     /* child that already terminated? */
2686
2687     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
2688         if (closed_list[j].pid == pid) {
2689             if (statusp) *statusp = closed_list[j].completion;
2690             return pid;
2691         }
2692     }
2693
2694     /* fall through if this child is not one of our own pipe children */
2695
2696 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2697
2698       /* waitpid() became available in the CRTL as of VMS 7.0, but only
2699        * in 7.2 did we get a version that fills in the VMS completion
2700        * status as Perl has always tried to do.
2701        */
2702
2703       sts = __vms_waitpid( pid, statusp, flags );
2704
2705       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2706          return sts;
2707
2708       /* If the real waitpid tells us the child does not exist, we
2709        * fall through here to implement waiting for a child that
2710        * was created by some means other than exec() (say, spawned
2711        * from DCL) or to wait for a process that is not a subprocess
2712        * of the current process.
2713        */
2714
2715 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2716
2717     {
2718       $DESCRIPTOR(intdsc,"0 00:00:01");
2719       unsigned long int ownercode = JPI$_OWNER, ownerpid;
2720       unsigned long int pidcode = JPI$_PID, mypid;
2721       unsigned long int interval[2];
2722       unsigned int jpi_iosb[2];
2723       struct itmlst_3 jpilist[2] = {
2724           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
2725           {                      0,         0,                 0, 0}
2726       };
2727
2728       if (pid <= 0) {
2729         /* Sorry folks, we don't presently implement rooting around for
2730            the first child we can find, and we definitely don't want to
2731            pass a pid of -1 to $getjpi, where it is a wildcard operation.
2732          */
2733         set_errno(ENOTSUP);
2734         return -1;
2735       }
2736
2737       /* Get the owner of the child so I can warn if it's not mine. If the
2738        * process doesn't exist or I don't have the privs to look at it,
2739        * I can go home early.
2740        */
2741       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2742       if (sts & 1) sts = jpi_iosb[0];
2743       if (!(sts & 1)) {
2744         switch (sts) {
2745             case SS$_NONEXPR:
2746                 set_errno(ECHILD);
2747                 break;
2748             case SS$_NOPRIV:
2749                 set_errno(EACCES);
2750                 break;
2751             default:
2752                 _ckvmssts(sts);
2753         }
2754         set_vaxc_errno(sts);
2755         return -1;
2756       }
2757
2758       if (ckWARN(WARN_EXEC)) {
2759         /* remind folks they are asking for non-standard waitpid behavior */
2760         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2761         if (ownerpid != mypid)
2762           Perl_warner(aTHX_ packWARN(WARN_EXEC),
2763                       "waitpid: process %x is not a child of process %x",
2764                       pid,mypid);
2765       }
2766
2767       /* simply check on it once a second until it's not there anymore. */
2768
2769       _ckvmssts(sys$bintim(&intdsc,interval));
2770       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2771             _ckvmssts(sys$schdwk(0,0,interval,0));
2772             _ckvmssts(sys$hiber());
2773       }
2774       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2775
2776       _ckvmssts(sts);
2777       return pid;
2778     }
2779 }  /* end of waitpid() */
2780 /*}}}*/
2781 /*}}}*/
2782 /*}}}*/
2783
2784 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2785 char *
2786 my_gconvert(double val, int ndig, int trail, char *buf)
2787 {
2788   static char __gcvtbuf[DBL_DIG+1];
2789   char *loc;
2790
2791   loc = buf ? buf : __gcvtbuf;
2792
2793 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
2794   if (val < 1) {
2795     sprintf(loc,"%.*g",ndig,val);
2796     return loc;
2797   }
2798 #endif
2799
2800   if (val) {
2801     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2802     return gcvt(val,ndig,loc);
2803   }
2804   else {
2805     loc[0] = '0'; loc[1] = '\0';
2806     return loc;
2807   }
2808
2809 }
2810 /*}}}*/
2811
2812
2813 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2814 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2815  * to expand file specification.  Allows for a single default file
2816  * specification and a simple mask of options.  If outbuf is non-NULL,
2817  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2818  * the resultant file specification is placed.  If outbuf is NULL, the
2819  * resultant file specification is placed into a static buffer.
2820  * The third argument, if non-NULL, is taken to be a default file
2821  * specification string.  The fourth argument is unused at present.
2822  * rmesexpand() returns the address of the resultant string if
2823  * successful, and NULL on error.
2824  */
2825 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2826
2827 static char *
2828 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2829 {
2830   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2831   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2832   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2833   struct FAB myfab = cc$rms_fab;
2834   struct NAM mynam = cc$rms_nam;
2835   STRLEN speclen;
2836   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2837
2838   if (!filespec || !*filespec) {
2839     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2840     return NULL;
2841   }
2842   if (!outbuf) {
2843     if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2844     else    outbuf = __rmsexpand_retbuf;
2845   }
2846   if ((isunix = (strchr(filespec,'/') != NULL))) {
2847     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2848     filespec = vmsfspec;
2849   }
2850
2851   myfab.fab$l_fna = filespec;
2852   myfab.fab$b_fns = strlen(filespec);
2853   myfab.fab$l_nam = &mynam;
2854
2855   if (defspec && *defspec) {
2856     if (strchr(defspec,'/') != NULL) {
2857       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2858       defspec = tmpfspec;
2859     }
2860     myfab.fab$l_dna = defspec;
2861     myfab.fab$b_dns = strlen(defspec);
2862   }
2863
2864   mynam.nam$l_esa = esa;
2865   mynam.nam$b_ess = sizeof esa;
2866   mynam.nam$l_rsa = outbuf;
2867   mynam.nam$b_rss = NAM$C_MAXRSS;
2868
2869   retsts = sys$parse(&myfab,0,0);
2870   if (!(retsts & 1)) {
2871     mynam.nam$b_nop |= NAM$M_SYNCHK;
2872     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2873       retsts = sys$parse(&myfab,0,0);
2874       if (retsts & 1) goto expanded;
2875     }
2876     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2877     (void) sys$parse(&myfab,0,0);  /* Free search context */
2878     if (out) Safefree(out);
2879     set_vaxc_errno(retsts);
2880     if      (retsts == RMS$_PRV) set_errno(EACCES);
2881     else if (retsts == RMS$_DEV) set_errno(ENODEV);
2882     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2883     else                         set_errno(EVMSERR);
2884     return NULL;
2885   }
2886   retsts = sys$search(&myfab,0,0);
2887   if (!(retsts & 1) && retsts != RMS$_FNF) {
2888     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2889     myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
2890     if (out) Safefree(out);
2891     set_vaxc_errno(retsts);
2892     if      (retsts == RMS$_PRV) set_errno(EACCES);
2893     else                         set_errno(EVMSERR);
2894     return NULL;
2895   }
2896
2897   /* If the input filespec contained any lowercase characters,
2898    * downcase the result for compatibility with Unix-minded code. */
2899   expanded:
2900   for (out = myfab.fab$l_fna; *out; out++)
2901     if (islower(*out)) { haslower = 1; break; }
2902   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2903   else                 { out = esa;    speclen = mynam.nam$b_esl; }
2904   /* Trim off null fields added by $PARSE
2905    * If type > 1 char, must have been specified in original or default spec
2906    * (not true for version; $SEARCH may have added version of existing file).
2907    */
2908   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2909   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2910              (mynam.nam$l_ver - mynam.nam$l_type == 1);
2911   if (trimver || trimtype) {
2912     if (defspec && *defspec) {
2913       char defesa[NAM$C_MAXRSS];
2914       struct FAB deffab = cc$rms_fab;
2915       struct NAM defnam = cc$rms_nam;
2916
2917       deffab.fab$l_nam = &defnam;
2918       deffab.fab$l_fna = defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
2919       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
2920       defnam.nam$b_nop = NAM$M_SYNCHK;
2921       if (sys$parse(&deffab,0,0) & 1) {
2922         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2923         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2924       }
2925     }
2926     if (trimver) speclen = mynam.nam$l_ver - out;
2927     if (trimtype) {
2928       /* If we didn't already trim version, copy down */
2929       if (speclen > mynam.nam$l_ver - out)
2930         memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2931                speclen - (mynam.nam$l_ver - out));
2932       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2933     }
2934   }
2935   /* If we just had a directory spec on input, $PARSE "helpfully"
2936    * adds an empty name and type for us */
2937   if (mynam.nam$l_name == mynam.nam$l_type &&
2938       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
2939       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2940     speclen = mynam.nam$l_name - out;
2941   out[speclen] = '\0';
2942   if (haslower) __mystrtolower(out);
2943
2944   /* Have we been working with an expanded, but not resultant, spec? */
2945   /* Also, convert back to Unix syntax if necessary. */
2946   if (!mynam.nam$b_rsl) {
2947     if (isunix) {
2948       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2949     }
2950     else strcpy(outbuf,esa);
2951   }
2952   else if (isunix) {
2953     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2954     strcpy(outbuf,tmpfspec);
2955   }
2956   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2957   mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2958   myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
2959   return outbuf;
2960 }
2961 /*}}}*/
2962 /* External entry points */
2963 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2964 { return do_rmsexpand(spec,buf,0,def,opt); }
2965 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2966 { return do_rmsexpand(spec,buf,1,def,opt); }
2967
2968
2969 /*
2970 ** The following routines are provided to make life easier when
2971 ** converting among VMS-style and Unix-style directory specifications.
2972 ** All will take input specifications in either VMS or Unix syntax. On
2973 ** failure, all return NULL.  If successful, the routines listed below
2974 ** return a pointer to a buffer containing the appropriately
2975 ** reformatted spec (and, therefore, subsequent calls to that routine
2976 ** will clobber the result), while the routines of the same names with
2977 ** a _ts suffix appended will return a pointer to a mallocd string
2978 ** containing the appropriately reformatted spec.
2979 ** In all cases, only explicit syntax is altered; no check is made that
2980 ** the resulting string is valid or that the directory in question
2981 ** actually exists.
2982 **
2983 **   fileify_dirspec() - convert a directory spec into the name of the
2984 **     directory file (i.e. what you can stat() to see if it's a dir).
2985 **     The style (VMS or Unix) of the result is the same as the style
2986 **     of the parameter passed in.
2987 **   pathify_dirspec() - convert a directory spec into a path (i.e.
2988 **     what you prepend to a filename to indicate what directory it's in).
2989 **     The style (VMS or Unix) of the result is the same as the style
2990 **     of the parameter passed in.
2991 **   tounixpath() - convert a directory spec into a Unix-style path.
2992 **   tovmspath() - convert a directory spec into a VMS-style path.
2993 **   tounixspec() - convert any file spec into a Unix-style file spec.
2994 **   tovmsspec() - convert any file spec into a VMS-style spec.
2995 **
2996 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
2997 ** Permission is given to distribute this code as part of the Perl
2998 ** standard distribution under the terms of the GNU General Public
2999 ** License or the Perl Artistic License.  Copies of each may be
3000 ** found in the Perl standard distribution.
3001  */
3002
3003 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
3004 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
3005 {
3006     static char __fileify_retbuf[NAM$C_MAXRSS+1];
3007     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
3008     char *retspec, *cp1, *cp2, *lastdir;
3009     char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
3010
3011     if (!dir || !*dir) {
3012       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3013     }
3014     dirlen = strlen(dir);
3015     while (dirlen && dir[dirlen-1] == '/') --dirlen;
3016     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3017       strcpy(trndir,"/sys$disk/000000");
3018       dir = trndir;
3019       dirlen = 16;
3020     }
3021     if (dirlen > NAM$C_MAXRSS) {
3022       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3023     }
3024     if (!strpbrk(dir+1,"/]>:")) {
3025       strcpy(trndir,*dir == '/' ? dir + 1: dir);
3026       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
3027       dir = trndir;
3028       dirlen = strlen(dir);
3029     }
3030     else {
3031       strncpy(trndir,dir,dirlen);
3032       trndir[dirlen] = '\0';
3033       dir = trndir;
3034     }
3035     /* If we were handed a rooted logical name or spec, treat it like a
3036      * simple directory, so that
3037      *    $ Define myroot dev:[dir.]
3038      *    ... do_fileify_dirspec("myroot",buf,1) ...
3039      * does something useful.
3040      */
3041     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
3042       dir[--dirlen] = '\0';
3043       dir[dirlen-1] = ']';
3044     }
3045     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
3046       dir[--dirlen] = '\0';
3047       dir[dirlen-1] = '>';
3048     }
3049
3050     if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
3051       /* If we've got an explicit filename, we can just shuffle the string. */
3052       if (*(cp1+1)) hasfilename = 1;
3053       /* Similarly, we can just back up a level if we've got multiple levels
3054          of explicit directories in a VMS spec which ends with directories. */
3055       else {
3056         for (cp2 = cp1; cp2 > dir; cp2--) {
3057           if (*cp2 == '.') {
3058             *cp2 = *cp1; *cp1 = '\0';
3059             hasfilename = 1;
3060             break;
3061           }
3062           if (*cp2 == '[' || *cp2 == '<') break;
3063         }
3064       }
3065     }
3066
3067     if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
3068       if (dir[0] == '.') {
3069         if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
3070           return do_fileify_dirspec("[]",buf,ts);
3071         else if (dir[1] == '.' &&
3072                  (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
3073           return do_fileify_dirspec("[-]",buf,ts);
3074       }
3075       if (dirlen && dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
3076         dirlen -= 1;                 /* to last element */
3077         lastdir = strrchr(dir,'/');
3078       }
3079       else if ((cp1 = strstr(dir,"/.")) != NULL) {
3080         /* If we have "/." or "/..", VMSify it and let the VMS code
3081          * below expand it, rather than repeating the code to handle
3082          * relative components of a filespec here */
3083         do {
3084           if (*(cp1+2) == '.') cp1++;
3085           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3086             if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3087             if (strchr(vmsdir,'/') != NULL) {
3088               /* If do_tovmsspec() returned it, it must have VMS syntax
3089                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
3090                * the time to check this here only so we avoid a recursion
3091                * loop; otherwise, gigo.
3092                */
3093               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
3094             }
3095             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3096             return do_tounixspec(trndir,buf,ts);
3097           }
3098           cp1++;
3099         } while ((cp1 = strstr(cp1,"/.")) != NULL);
3100         lastdir = strrchr(dir,'/');
3101       }
3102       else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
3103         /* Ditto for specs that end in an MFD -- let the VMS code
3104          * figure out whether it's a real device or a rooted logical. */
3105         dir[dirlen] = '/'; dir[dirlen+1] = '\0';
3106         if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3107         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3108         return do_tounixspec(trndir,buf,ts);
3109       }
3110       else {
3111         if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
3112              !(lastdir = cp1 = strrchr(dir,']')) &&
3113              !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
3114         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
3115           int ver; char *cp3;
3116           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3117               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3118               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3119               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3120               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3121                             (ver || *cp3)))))) {
3122             set_errno(ENOTDIR);
3123             set_vaxc_errno(RMS$_DIR);
3124             return NULL;
3125           }
3126           dirlen = cp2 - dir;
3127         }
3128       }
3129       /* If we lead off with a device or rooted logical, add the MFD
3130          if we're specifying a top-level directory. */
3131       if (lastdir && *dir == '/') {
3132         addmfd = 1;
3133         for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
3134           if (*cp1 == '/') {
3135             addmfd = 0;
3136             break;
3137           }
3138         }
3139       }
3140       retlen = dirlen + (addmfd ? 13 : 6);
3141       if (buf) retspec = buf;
3142       else if (ts) New(1309,retspec,retlen+1,char);
3143       else retspec = __fileify_retbuf;
3144       if (addmfd) {
3145         dirlen = lastdir - dir;
3146         memcpy(retspec,dir,dirlen);
3147         strcpy(&retspec[dirlen],"/000000");
3148         strcpy(&retspec[dirlen+7],lastdir);
3149       }
3150       else {
3151         memcpy(retspec,dir,dirlen);
3152         retspec[dirlen] = '\0';
3153       }
3154       /* We've picked up everything up to the directory file name.
3155          Now just add the type and version, and we're set. */
3156       strcat(retspec,".dir;1");
3157       return retspec;
3158     }
3159     else {  /* VMS-style directory spec */
3160       char esa[NAM$C_MAXRSS+1], term, *cp;
3161       unsigned long int sts, cmplen, haslower = 0;
3162       struct FAB dirfab = cc$rms_fab;
3163       struct NAM savnam, dirnam = cc$rms_nam;
3164
3165       dirfab.fab$b_fns = strlen(dir);
3166       dirfab.fab$l_fna = dir;
3167       dirfab.fab$l_nam = &dirnam;
3168       dirfab.fab$l_dna = ".DIR;1";
3169       dirfab.fab$b_dns = 6;
3170       dirnam.nam$b_ess = NAM$C_MAXRSS;
3171       dirnam.nam$l_esa = esa;
3172
3173       for (cp = dir; *cp; cp++)
3174         if (islower(*cp)) { haslower = 1; break; }
3175       if (!((sts = sys$parse(&dirfab))&1)) {
3176         if (dirfab.fab$l_sts == RMS$_DIR) {
3177           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3178           sts = sys$parse(&dirfab) & 1;
3179         }
3180         if (!sts) {
3181           set_errno(EVMSERR);
3182           set_vaxc_errno(dirfab.fab$l_sts);
3183           return NULL;
3184         }
3185       }
3186       else {
3187         savnam = dirnam;
3188         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
3189           /* Yes; fake the fnb bits so we'll check type below */
3190           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3191         }
3192         else { /* No; just work with potential name */
3193           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3194           else {
3195             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
3196             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3197             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3198             return NULL;
3199           }
3200         }
3201       }
3202       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3203         cp1 = strchr(esa,']');
3204         if (!cp1) cp1 = strchr(esa,'>');
3205         if (cp1) {  /* Should always be true */
3206           dirnam.nam$b_esl -= cp1 - esa - 1;
3207           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3208         }
3209       }
3210       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3211         /* Yep; check version while we're at it, if it's there. */
3212         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3213         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3214           /* Something other than .DIR[;1].  Bzzt. */
3215           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3216           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3217           set_errno(ENOTDIR);
3218           set_vaxc_errno(RMS$_DIR);
3219           return NULL;
3220         }
3221       }
3222       esa[dirnam.nam$b_esl] = '\0';
3223       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3224         /* They provided at least the name; we added the type, if necessary, */
3225         if (buf) retspec = buf;                            /* in sys$parse() */
3226         else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3227         else retspec = __fileify_retbuf;
3228         strcpy(retspec,esa);
3229         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3230         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3231         return retspec;
3232       }
3233       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3234         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3235         *cp1 = '\0';
3236         dirnam.nam$b_esl -= 9;
3237       }
3238       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3239       if (cp1 == NULL) { /* should never happen */
3240         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3241         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3242         return NULL;
3243       }
3244       term = *cp1;
3245       *cp1 = '\0';
3246       retlen = strlen(esa);
3247       if ((cp1 = strrchr(esa,'.')) != NULL) {
3248         /* There's more than one directory in the path.  Just roll back. */
3249         *cp1 = term;
3250         if (buf) retspec = buf;
3251         else if (ts) New(1311,retspec,retlen+7,char);
3252         else retspec = __fileify_retbuf;
3253         strcpy(retspec,esa);
3254       }
3255       else {
3256         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3257           /* Go back and expand rooted logical name */
3258           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3259           if (!(sys$parse(&dirfab) & 1)) {
3260             dirnam.nam$l_rlf = NULL;
3261             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3262             set_errno(EVMSERR);
3263             set_vaxc_errno(dirfab.fab$l_sts);
3264             return NULL;
3265           }
3266           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3267           if (buf) retspec = buf;
3268           else if (ts) New(1312,retspec,retlen+16,char);
3269           else retspec = __fileify_retbuf;
3270           cp1 = strstr(esa,"][");
3271           if (!cp1) cp1 = strstr(esa,"]<");
3272           dirlen = cp1 - esa;
3273           memcpy(retspec,esa,dirlen);
3274           if (!strncmp(cp1+2,"000000]",7)) {
3275             retspec[dirlen-1] = '\0';
3276             for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3277             if (*cp1 == '.') *cp1 = ']';
3278             else {
3279               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3280               memcpy(cp1+1,"000000]",7);
3281             }
3282           }
3283           else {
3284             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3285             retspec[retlen] = '\0';
3286             /* Convert last '.' to ']' */
3287             for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3288             if (*cp1 == '.') *cp1 = ']';
3289             else {
3290               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3291               memcpy(cp1+1,"000000]",7);
3292             }
3293           }
3294         }
3295         else {  /* This is a top-level dir.  Add the MFD to the path. */
3296           if (buf) retspec = buf;
3297           else if (ts) New(1312,retspec,retlen+16,char);
3298           else retspec = __fileify_retbuf;
3299           cp1 = esa;
3300           cp2 = retspec;
3301           while (*cp1 != ':') *(cp2++) = *(cp1++);
3302           strcpy(cp2,":[000000]");
3303           cp1 += 2;
3304           strcpy(cp2+9,cp1);
3305         }
3306       }
3307       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3308       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3309       /* We've set up the string up through the filename.  Add the
3310          type and version, and we're done. */
3311       strcat(retspec,".DIR;1");
3312
3313       /* $PARSE may have upcased filespec, so convert output to lower
3314        * case if input contained any lowercase characters. */
3315       if (haslower) __mystrtolower(retspec);
3316       return retspec;
3317     }
3318 }  /* end of do_fileify_dirspec() */
3319 /*}}}*/
3320 /* External entry points */
3321 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3322 { return do_fileify_dirspec(dir,buf,0); }
3323 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3324 { return do_fileify_dirspec(dir,buf,1); }
3325
3326 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3327 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3328 {
3329     static char __pathify_retbuf[NAM$C_MAXRSS+1];
3330     unsigned long int retlen;
3331     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3332
3333     if (!dir || !*dir) {
3334       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3335     }
3336
3337     if (*dir) strcpy(trndir,dir);
3338     else getcwd(trndir,sizeof trndir - 1);
3339
3340     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3341            && my_trnlnm(trndir,trndir,0)) {
3342       STRLEN trnlen = strlen(trndir);
3343
3344       /* Trap simple rooted lnms, and return lnm:[000000] */
3345       if (!strcmp(trndir+trnlen-2,".]")) {
3346         if (buf) retpath = buf;
3347         else if (ts) New(1318,retpath,strlen(dir)+10,char);
3348         else retpath = __pathify_retbuf;
3349         strcpy(retpath,dir);
3350         strcat(retpath,":[000000]");
3351         return retpath;
3352       }
3353     }
3354     dir = trndir;
3355
3356     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3357       if (*dir == '.' && (*(dir+1) == '\0' ||
3358                           (*(dir+1) == '.' && *(dir+2) == '\0')))
3359         retlen = 2 + (*(dir+1) != '\0');
3360       else {
3361         if ( !(cp1 = strrchr(dir,'/')) &&
3362              !(cp1 = strrchr(dir,']')) &&
3363              !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3364         if ((cp2 = strchr(cp1,'.')) != NULL &&
3365             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
3366              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
3367               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3368               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3369           int ver; char *cp3;
3370           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3371               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3372               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3373               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3374               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3375                             (ver || *cp3)))))) {
3376             set_errno(ENOTDIR);
3377             set_vaxc_errno(RMS$_DIR);
3378             return NULL;
3379           }
3380           retlen = cp2 - dir + 1;
3381         }
3382         else {  /* No file type present.  Treat the filename as a directory. */
3383           retlen = strlen(dir) + 1;
3384         }
3385       }
3386       if (buf) retpath = buf;
3387       else if (ts) New(1313,retpath,retlen+1,char);
3388       else retpath = __pathify_retbuf;
3389       strncpy(retpath,dir,retlen-1);
3390       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3391         retpath[retlen-1] = '/';      /* with '/', add it. */
3392         retpath[retlen] = '\0';
3393       }
3394       else retpath[retlen-1] = '\0';
3395     }
3396     else {  /* VMS-style directory spec */
3397       char esa[NAM$C_MAXRSS+1], *cp;
3398       unsigned long int sts, cmplen, haslower;
3399       struct FAB dirfab = cc$rms_fab;
3400       struct NAM savnam, dirnam = cc$rms_nam;
3401
3402       /* If we've got an explicit filename, we can just shuffle the string. */
3403       if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3404              (cp1 = strrchr(dir,'>')) != NULL     ) && *(cp1+1)) {
3405         if ((cp2 = strchr(cp1,'.')) != NULL) {
3406           int ver; char *cp3;
3407           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3408               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3409               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3410               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3411               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3412                             (ver || *cp3)))))) {
3413             set_errno(ENOTDIR);
3414             set_vaxc_errno(RMS$_DIR);
3415             return NULL;
3416           }
3417         }
3418         else {  /* No file type, so just draw name into directory part */
3419           for (cp2 = cp1; *cp2; cp2++) ;
3420         }
3421         *cp2 = *cp1;
3422         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
3423         *cp1 = '.';
3424         /* We've now got a VMS 'path'; fall through */
3425       }
3426       dirfab.fab$b_fns = strlen(dir);
3427       dirfab.fab$l_fna = dir;
3428       if (dir[dirfab.fab$b_fns-1] == ']' ||
3429           dir[dirfab.fab$b_fns-1] == '>' ||
3430           dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3431         if (buf) retpath = buf;
3432         else if (ts) New(1314,retpath,strlen(dir)+1,char);
3433         else retpath = __pathify_retbuf;
3434         strcpy(retpath,dir);
3435         return retpath;
3436       }
3437       dirfab.fab$l_dna = ".DIR;1";
3438       dirfab.fab$b_dns = 6;
3439       dirfab.fab$l_nam = &dirnam;
3440       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3441       dirnam.nam$l_esa = esa;
3442
3443       for (cp = dir; *cp; cp++)
3444         if (islower(*cp)) { haslower = 1; break; }
3445
3446       if (!(sts = (sys$parse(&dirfab)&1))) {
3447         if (dirfab.fab$l_sts == RMS$_DIR) {
3448           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3449           sts = sys$parse(&dirfab) & 1;
3450         }
3451         if (!sts) {
3452           set_errno(EVMSERR);
3453           set_vaxc_errno(dirfab.fab$l_sts);
3454           return NULL;
3455         }
3456       }
3457       else {
3458         savnam = dirnam;
3459         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
3460           if (dirfab.fab$l_sts != RMS$_FNF) {
3461             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3462             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3463             set_errno(EVMSERR);
3464             set_vaxc_errno(dirfab.fab$l_sts);
3465             return NULL;
3466           }
3467           dirnam = savnam; /* No; just work with potential name */
3468         }
3469       }
3470       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3471         /* Yep; check version while we're at it, if it's there. */
3472         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3473         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3474           /* Something other than .DIR[;1].  Bzzt. */
3475           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3476           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3477           set_errno(ENOTDIR);
3478           set_vaxc_errno(RMS$_DIR);
3479           return NULL;
3480         }
3481       }
3482       /* OK, the type was fine.  Now pull any file name into the
3483          directory path. */
3484       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3485       else {
3486         cp1 = strrchr(esa,'>');
3487         *dirnam.nam$l_type = '>';
3488       }
3489       *cp1 = '.';
3490       *(dirnam.nam$l_type + 1) = '\0';
3491       retlen = dirnam.nam$l_type - esa + 2;
3492       if (buf) retpath = buf;
3493       else if (ts) New(1314,retpath,retlen,char);
3494       else retpath = __pathify_retbuf;
3495       strcpy(retpath,esa);
3496       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3497       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3498       /* $PARSE may have upcased filespec, so convert output to lower
3499        * case if input contained any lowercase characters. */
3500       if (haslower) __mystrtolower(retpath);
3501     }
3502
3503     return retpath;
3504 }  /* end of do_pathify_dirspec() */
3505 /*}}}*/
3506 /* External entry points */
3507 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3508 { return do_pathify_dirspec(dir,buf,0); }
3509 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3510 { return do_pathify_dirspec(dir,buf,1); }
3511
3512 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3513 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3514 {
3515   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3516   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3517   int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3518
3519   if (spec == NULL) return NULL;
3520   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3521   if (buf) rslt = buf;
3522   else if (ts) {
3523     retlen = strlen(spec);
3524     cp1 = strchr(spec,'[');
3525     if (!cp1) cp1 = strchr(spec,'<');
3526     if (cp1) {
3527       for (cp1++; *cp1; cp1++) {
3528         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
3529         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3530           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3531       }
3532     }
3533     New(1315,rslt,retlen+2+2*expand,char);
3534   }
3535   else rslt = __tounixspec_retbuf;
3536   if (strchr(spec,'/') != NULL) {
3537     strcpy(rslt,spec);
3538     return rslt;
3539   }
3540
3541   cp1 = rslt;
3542   cp2 = spec;
3543   dirend = strrchr(spec,']');
3544   if (dirend == NULL) dirend = strrchr(spec,'>');
3545   if (dirend == NULL) dirend = strchr(spec,':');
3546   if (dirend == NULL) {
3547     strcpy(rslt,spec);
3548     return rslt;
3549   }
3550   if (*cp2 != '[' && *cp2 != '<') {
3551     *(cp1++) = '/';
3552   }
3553   else {  /* the VMS spec begins with directories */
3554     cp2++;
3555     if (*cp2 == ']' || *cp2 == '>') {
3556       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3557       return rslt;
3558     }
3559     else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3560       if (getcwd(tmp,sizeof tmp,1) == NULL) {
3561         if (ts) Safefree(rslt);
3562         return NULL;
3563       }
3564       do {
3565         cp3 = tmp;
3566         while (*cp3 != ':' && *cp3) cp3++;
3567         *(cp3++) = '\0';
3568         if (strchr(cp3,']') != NULL) break;
3569       } while (vmstrnenv(tmp,tmp,0,fildev,0));
3570       if (ts && !buf &&
3571           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3572         retlen = devlen + dirlen;
3573         Renew(rslt,retlen+1+2*expand,char);
3574         cp1 = rslt;
3575       }
3576       cp3 = tmp;
3577       *(cp1++) = '/';
3578       while (*cp3) {
3579         *(cp1++) = *(cp3++);
3580         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3581       }
3582       *(cp1++) = '/';
3583     }
3584     else if ( *cp2 == '.') {
3585       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3586         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3587         cp2 += 3;
3588       }
3589       else cp2++;
3590     }
3591   }
3592   for (; cp2 <= dirend; cp2++) {
3593     if (*cp2 == ':') {
3594       *(cp1++) = '/';
3595       if (*(cp2+1) == '[') cp2++;
3596     }
3597     else if (*cp2 == ']' || *cp2 == '>') {
3598       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3599     }
3600     else if (*cp2 == '.') {
3601       *(cp1++) = '/';
3602       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3603         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3604                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3605         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3606             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3607       }
3608       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3609         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3610         cp2 += 2;
3611       }
3612     }
3613     else if (*cp2 == '-') {
3614       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3615         while (*cp2 == '-') {
3616           cp2++;
3617           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3618         }
3619         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3620           if (ts) Safefree(rslt);                        /* filespecs like */
3621           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
3622           return NULL;
3623         }
3624       }
3625       else *(cp1++) = *cp2;
3626     }
3627     else *(cp1++) = *cp2;
3628   }
3629   while (*cp2) *(cp1++) = *(cp2++);
3630   *cp1 = '\0';
3631
3632   return rslt;
3633
3634 }  /* end of do_tounixspec() */
3635 /*}}}*/
3636 /* External entry points */
3637 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3638 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3639
3640 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3641 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3642   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3643   char *rslt, *dirend;
3644   register char *cp1, *cp2;
3645   unsigned long int infront = 0, hasdir = 1;
3646
3647   if (path == NULL) return NULL;
3648   if (buf) rslt = buf;
3649   else if (ts) New(1316,rslt,strlen(path)+9,char);
3650   else rslt = __tovmsspec_retbuf;
3651   if (strpbrk(path,"]:>") ||
3652       (dirend = strrchr(path,'/')) == NULL) {
3653     if (path[0] == '.') {
3654       if (path[1] == '\0') strcpy(rslt,"[]");
3655       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3656       else strcpy(rslt,path); /* probably garbage */
3657     }
3658     else strcpy(rslt,path);
3659     return rslt;
3660   }
3661   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
3662     if (!*(dirend+2)) dirend +=2;
3663     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3664     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3665   }
3666   cp1 = rslt;
3667   cp2 = path;
3668   if (*cp2 == '/') {
3669     char trndev[NAM$C_MAXRSS+1];
3670     int islnm, rooted;
3671     STRLEN trnend;
3672
3673     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
3674     if (!*(cp2+1)) {
3675       if (!buf & ts) Renew(rslt,18,char);
3676       strcpy(rslt,"sys$disk:[000000]");
3677       return rslt;
3678     }
3679     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3680     *cp1 = '\0';
3681     islnm =  my_trnlnm(rslt,trndev,0);
3682     trnend = islnm ? strlen(trndev) - 1 : 0;
3683     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3684     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3685     /* If the first element of the path is a logical name, determine
3686      * whether it has to be translated so we can add more directories. */
3687     if (!islnm || rooted) {
3688       *(cp1++) = ':';
3689       *(cp1++) = '[';
3690       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3691       else cp2++;
3692     }
3693     else {
3694       if (cp2 != dirend) {
3695         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3696         strcpy(rslt,trndev);
3697         cp1 = rslt + trnend;
3698         *(cp1++) = '.';
3699         cp2++;
3700       }
3701       else {
3702         *(cp1++) = ':';
3703         hasdir = 0;
3704       }
3705     }
3706   }
3707   else {
3708     *(cp1++) = '[';
3709     if (*cp2 == '.') {
3710       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3711         cp2 += 2;         /* skip over "./" - it's redundant */
3712         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
3713       }
3714       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3715         *(cp1++) = '-';                                 /* "../" --> "-" */
3716         cp2 += 3;
3717       }
3718       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3719                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3720         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3721         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3722         cp2 += 4;
3723       }
3724       if (cp2 > dirend) cp2 = dirend;
3725     }
3726     else *(cp1++) = '.';
3727   }
3728   for (; cp2 < dirend; cp2++) {
3729     if (*cp2 == '/') {
3730       if (*(cp2-1) == '/') continue;
3731       if (*(cp1-1) != '.') *(cp1++) = '.';
3732       infront = 0;
3733     }
3734     else if (!infront && *cp2 == '.') {
3735       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3736       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
3737       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3738         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3739         else if (*(cp1-2) == '[') *(cp1-1) = '-';
3740         else {  /* back up over previous directory name */
3741           cp1--;
3742           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3743           if (*(cp1-1) == '[') {
3744             memcpy(cp1,"000000.",7);
3745             cp1 += 7;
3746           }
3747         }
3748         cp2 += 2;
3749         if (cp2 == dirend) break;
3750       }
3751       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3752                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3753         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3754         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3755         if (!*(cp2+3)) {
3756           *(cp1++) = '.';  /* Simulate trailing '/' */
3757           cp2 += 2;  /* for loop will incr this to == dirend */
3758         }
3759         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
3760       }
3761       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
3762     }
3763     else {
3764       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
3765       if (*cp2 == '.')      *(cp1++) = '_';
3766       else                  *(cp1++) =  *cp2;
3767       infront = 1;
3768     }
3769   }
3770   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3771   if (hasdir) *(cp1++) = ']';
3772   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
3773   while (*cp2) *(cp1++) = *(cp2++);
3774   *cp1 = '\0';
3775
3776   return rslt;
3777
3778 }  /* end of do_tovmsspec() */
3779 /*}}}*/
3780 /* External entry points */
3781 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3782 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3783
3784 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3785 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3786   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3787   int vmslen;
3788   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3789
3790   if (path == NULL) return NULL;
3791   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3792   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3793   if (buf) return buf;
3794   else if (ts) {
3795     vmslen = strlen(vmsified);
3796     New(1317,cp,vmslen+1,char);
3797     memcpy(cp,vmsified,vmslen);
3798     cp[vmslen] = '\0';
3799     return cp;
3800   }
3801   else {
3802     strcpy(__tovmspath_retbuf,vmsified);
3803     return __tovmspath_retbuf;
3804   }
3805
3806 }  /* end of do_tovmspath() */
3807 /*}}}*/
3808 /* External entry points */
3809 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3810 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3811
3812
3813 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3814 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3815   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3816   int unixlen;
3817   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3818
3819   if (path == NULL) return NULL;
3820   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3821   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3822   if (buf) return buf;
3823   else if (ts) {
3824     unixlen = strlen(unixified);
3825     New(1317,cp,unixlen+1,char);
3826     memcpy(cp,unixified,unixlen);
3827     cp[unixlen] = '\0';
3828     return cp;
3829   }
3830   else {
3831     strcpy(__tounixpath_retbuf,unixified);
3832     return __tounixpath_retbuf;
3833   }
3834
3835 }  /* end of do_tounixpath() */
3836 /*}}}*/
3837 /* External entry points */
3838 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3839 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3840
3841 /*
3842  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
3843  *
3844  *****************************************************************************
3845  *                                                                           *
3846  *  Copyright (C) 1989-1994 by                                               *
3847  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
3848  *                                                                           *
3849  *  Permission is hereby  granted for the reproduction of this software,     *
3850  *  on condition that this copyright notice is included in the reproduction, *
3851  *  and that such reproduction is not for purposes of profit or material     *
3852  *  gain.                                                                    *
3853  *                                                                           *
3854  *  27-Aug-1994 Modified for inclusion in perl5                              *
3855  *              by Charles Bailey  bailey@newman.upenn.edu                   *
3856  *****************************************************************************
3857  */
3858
3859 /*
3860  * getredirection() is intended to aid in porting C programs
3861  * to VMS (Vax-11 C).  The native VMS environment does not support
3862  * '>' and '<' I/O redirection, or command line wild card expansion,
3863  * or a command line pipe mechanism using the '|' AND background
3864  * command execution '&'.  All of these capabilities are provided to any
3865  * C program which calls this procedure as the first thing in the
3866  * main program.
3867  * The piping mechanism will probably work with almost any 'filter' type
3868  * of program.  With suitable modification, it may useful for other
3869  * portability problems as well.
3870  *
3871  * Author:  Mark Pizzolato      mark@infocomm.com
3872  */
3873 struct list_item
3874     {
3875     struct list_item *next;
3876     char *value;
3877     };
3878
3879 static void add_item(struct list_item **head,
3880                      struct list_item **tail,
3881                      char *value,
3882                      int *count);
3883
3884 static void mp_expand_wild_cards(pTHX_ char *item,
3885                                 struct list_item **head,
3886                                 struct list_item **tail,
3887                                 int *count);
3888
3889 static int background_process(pTHX_ int argc, char **argv);
3890
3891 static void pipe_and_fork(pTHX_ char **cmargv);
3892
3893 /*{{{ void getredirection(int *ac, char ***av)*/
3894 static void
3895 mp_getredirection(pTHX_ int *ac, char ***av)
3896 /*
3897  * Process vms redirection arg's.  Exit if any error is seen.
3898  * If getredirection() processes an argument, it is erased
3899  * from the vector.  getredirection() returns a new argc and argv value.
3900  * In the event that a background command is requested (by a trailing "&"),
3901  * this routine creates a background subprocess, and simply exits the program.
3902  *
3903  * Warning: do not try to simplify the code for vms.  The code
3904  * presupposes that getredirection() is called before any data is
3905  * read from stdin or written to stdout.
3906  *
3907  * Normal usage is as follows:
3908  *
3909  *      main(argc, argv)
3910  *      int             argc;
3911  *      char            *argv[];
3912  *      {
3913  *              getredirection(&argc, &argv);
3914  *      }
3915  */
3916 {
3917     int                 argc = *ac;     /* Argument Count         */
3918     char                **argv = *av;   /* Argument Vector        */
3919     char                *ap;            /* Argument pointer       */
3920     int                 j;              /* argv[] index           */
3921     int                 item_count = 0; /* Count of Items in List */
3922     struct list_item    *list_head = 0; /* First Item in List       */
3923     struct list_item    *list_tail;     /* Last Item in List        */
3924     char                *in = NULL;     /* Input File Name          */
3925     char                *out = NULL;    /* Output File Name         */
3926     char                *outmode = "w"; /* Mode to Open Output File */
3927     char                *err = NULL;    /* Error File Name          */
3928     char                *errmode = "w"; /* Mode to Open Error File  */
3929     int                 cmargc = 0;     /* Piped Command Arg Count  */
3930     char                **cmargv = NULL;/* Piped Command Arg Vector */
3931
3932     /*
3933      * First handle the case where the last thing on the line ends with
3934      * a '&'.  This indicates the desire for the command to be run in a
3935      * subprocess, so we satisfy that desire.
3936      */
3937     ap = argv[argc-1];
3938     if (0 == strcmp("&", ap))
3939         exit(background_process(--argc, argv));
3940     if (*ap && '&' == ap[strlen(ap)-1])
3941         {
3942         ap[strlen(ap)-1] = '\0';
3943         exit(background_process(argc, argv));
3944         }
3945     /*
3946      * Now we handle the general redirection cases that involve '>', '>>',
3947      * '<', and pipes '|'.
3948      */
3949     for (j = 0; j < argc; ++j)
3950         {
3951         if (0 == strcmp("<", argv[j]))
3952             {
3953             if (j+1 >= argc)
3954                 {
3955                 fprintf(stderr,"No input file after < on command line");
3956                 exit(LIB$_WRONUMARG);
3957                 }
3958             in = argv[++j];
3959             continue;
3960             }
3961         if ('<' == *(ap = argv[j]))
3962             {
3963             in = 1 + ap;
3964             continue;
3965             }
3966         if (0 == strcmp(">", ap))
3967             {
3968             if (j+1 >= argc)
3969                 {
3970                 fprintf(stderr,"No output file after > on command line");
3971                 exit(LIB$_WRONUMARG);
3972                 }
3973             out = argv[++j];
3974             continue;
3975             }
3976         if ('>' == *ap)
3977             {
3978             if ('>' == ap[1])
3979                 {
3980                 outmode = "a";
3981                 if ('\0' == ap[2])
3982                     out = argv[++j];
3983                 else
3984                     out = 2 + ap;
3985                 }
3986             else
3987                 out = 1 + ap;
3988             if (j >= argc)
3989                 {
3990                 fprintf(stderr,"No output file after > or >> on command line");
3991                 exit(LIB$_WRONUMARG);
3992                 }
3993             continue;
3994             }
3995         if (('2' == *ap) && ('>' == ap[1]))
3996             {
3997             if ('>' == ap[2])
3998                 {
3999                 errmode = "a";
4000                 if ('\0' == ap[3])
4001                     err = argv[++j];
4002                 else
4003                     err = 3 + ap;
4004                 }
4005             else
4006                 if ('\0' == ap[2])
4007                     err = argv[++j];
4008                 else
4009                     err = 2 + ap;
4010             if (j >= argc)
4011                 {
4012                 fprintf(stderr,"No output file after 2> or 2>> on command line");
4013                 exit(LIB$_WRONUMARG);
4014                 }
4015             continue;
4016             }
4017         if (0 == strcmp("|", argv[j]))
4018             {
4019             if (j+1 >= argc)
4020                 {
4021                 fprintf(stderr,"No command into which to pipe on command line");
4022                 exit(LIB$_WRONUMARG);
4023                 }
4024             cmargc = argc-(j+1);
4025             cmargv = &argv[j+1];
4026             argc = j;
4027             continue;
4028             }
4029         if ('|' == *(ap = argv[j]))
4030             {
4031             ++argv[j];
4032             cmargc = argc-j;
4033             cmargv = &argv[j];
4034             argc = j;
4035             continue;
4036             }
4037         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4038         }
4039     /*
4040      * Allocate and fill in the new argument vector, Some Unix's terminate
4041      * the list with an extra null pointer.
4042      */
4043     New(1302, argv, item_count+1, char *);
4044     *av = argv;
4045     for (j = 0; j < item_count; ++j, list_head = list_head->next)
4046         argv[j] = list_head->value;
4047     *ac = item_count;
4048     if (cmargv != NULL)
4049         {
4050         if (out != NULL)
4051             {
4052             fprintf(stderr,"'|' and '>' may not both be specified on command line");
4053             exit(LIB$_INVARGORD);
4054             }
4055         pipe_and_fork(aTHX_ cmargv);
4056         }
4057
4058     /* Check for input from a pipe (mailbox) */
4059
4060     if (in == NULL && 1 == isapipe(0))
4061         {
4062         char mbxname[L_tmpnam];
4063         long int bufsize;
4064         long int dvi_item = DVI$_DEVBUFSIZ;
4065         $DESCRIPTOR(mbxnam, "");
4066         $DESCRIPTOR(mbxdevnam, "");
4067
4068         /* Input from a pipe, reopen it in binary mode to disable       */
4069         /* carriage control processing.                                 */
4070
4071         fgetname(stdin, mbxname);
4072         mbxnam.dsc$a_pointer = mbxname;
4073         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4074         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4075         mbxdevnam.dsc$a_pointer = mbxname;
4076         mbxdevnam.dsc$w_length = sizeof(mbxname);
4077         dvi_item = DVI$_DEVNAM;
4078         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4079         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4080         set_errno(0);
4081         set_vaxc_errno(1);
4082         freopen(mbxname, "rb", stdin);
4083         if (errno != 0)
4084             {
4085             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4086             exit(vaxc$errno);
4087             }
4088         }
4089     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4090         {
4091         fprintf(stderr,"Can't open input file %s as stdin",in);
4092         exit(vaxc$errno);
4093         }
4094     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4095         {
4096         fprintf(stderr,"Can't open output file %s as stdout",out);
4097         exit(vaxc$errno);
4098         }
4099         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4100
4101     if (err != NULL) {
4102         if (strcmp(err,"&1") == 0) {
4103             dup2(fileno(stdout), fileno(stderr));
4104             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4105         } else {
4106         FILE *tmperr;
4107         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4108             {
4109             fprintf(stderr,"Can't open error file %s as stderr",err);
4110             exit(vaxc$errno);
4111             }
4112             fclose(tmperr);
4113            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4114                 {
4115                 exit(vaxc$errno);
4116                 }
4117             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4118         }
4119         }
4120 #ifdef ARGPROC_DEBUG
4121     PerlIO_printf(Perl_debug_log, "Arglist:\n");
4122     for (j = 0; j < *ac;  ++j)
4123         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4124 #endif
4125    /* Clear errors we may have hit expanding wildcards, so they don't
4126       show up in Perl's $! later */
4127    set_errno(0); set_vaxc_errno(1);
4128 }  /* end of getredirection() */
4129 /*}}}*/
4130
4131 static void add_item(struct list_item **head,
4132                      struct list_item **tail,
4133                      char *value,
4134                      int *count)
4135 {
4136     if (*head == 0)
4137         {
4138         New(1303,*head,1,struct list_item);
4139         *tail = *head;
4140         }
4141     else {
4142         New(1304,(*tail)->next,1,struct list_item);
4143         *tail = (*tail)->next;
4144         }
4145     (*tail)->value = value;
4146     ++(*count);
4147 }
4148
4149 static void mp_expand_wild_cards(pTHX_ char *item,
4150                               struct list_item **head,
4151                               struct list_item **tail,
4152                               int *count)
4153 {
4154 int expcount = 0;
4155 unsigned long int context = 0;
4156 int isunix = 0;
4157 char *had_version;
4158 char *had_device;
4159 int had_directory;
4160 char *devdir,*cp;
4161 char vmsspec[NAM$C_MAXRSS+1];
4162 $DESCRIPTOR(filespec, "");
4163 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4164 $DESCRIPTOR(resultspec, "");
4165 unsigned long int zero = 0, sts;
4166
4167     for (cp = item; *cp; cp++) {
4168         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4169         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4170     }
4171     if (!*cp || isspace(*cp))
4172         {
4173         add_item(head, tail, item, count);
4174         return;
4175         }
4176     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4177     resultspec.dsc$b_class = DSC$K_CLASS_D;
4178     resultspec.dsc$a_pointer = NULL;
4179     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4180       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4181     if (!isunix || !filespec.dsc$a_pointer)
4182       filespec.dsc$a_pointer = item;
4183     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4184     /*
4185      * Only return version specs, if the caller specified a version
4186      */
4187     had_version = strchr(item, ';');
4188     /*
4189      * Only return device and directory specs, if the caller specifed either.
4190      */
4191     had_device = strchr(item, ':');
4192     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4193
4194     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4195                                   &defaultspec, 0, 0, &zero))))
4196         {
4197         char *string;
4198         char *c;
4199
4200         New(1305,string,resultspec.dsc$w_length+1,char);
4201         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4202         string[resultspec.dsc$w_length] = '\0';
4203         if (NULL == had_version)
4204             *((char *)strrchr(string, ';')) = '\0';
4205         if ((!had_directory) && (had_device == NULL))
4206             {
4207             if (NULL == (devdir = strrchr(string, ']')))
4208                 devdir = strrchr(string, '>');
4209             strcpy(string, devdir + 1);
4210             }
4211         /*
4212          * Be consistent with what the C RTL has already done to the rest of
4213          * the argv items and lowercase all of these names.
4214          */
4215         for (c = string; *c; ++c)
4216             if (isupper(*c))
4217                 *c = tolower(*c);
4218         if (isunix) trim_unixpath(string,item,1);
4219         add_item(head, tail, string, count);
4220         ++expcount;
4221         }
4222     if (sts != RMS$_NMF)
4223         {
4224         set_vaxc_errno(sts);
4225         switch (sts)
4226             {
4227             case RMS$_FNF: case RMS$_DNF:
4228                 set_errno(ENOENT); break;
4229             case RMS$_DIR:
4230                 set_errno(ENOTDIR); break;
4231             case RMS$_DEV:
4232                 set_errno(ENODEV); break;
4233             case RMS$_FNM: case RMS$_SYN:
4234                 set_errno(EINVAL); break;
4235             case RMS$_PRV:
4236                 set_errno(EACCES); break;
4237             default:
4238                 _ckvmssts_noperl(sts);
4239             }
4240         }
4241     if (expcount == 0)
4242         add_item(head, tail, item, count);
4243     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4244     _ckvmssts_noperl(lib$find_file_end(&context));
4245 }
4246
4247 static int child_st[2];/* Event Flag set when child process completes   */
4248
4249 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
4250
4251 static unsigned long int exit_handler(int *status)
4252 {
4253 short iosb[4];
4254
4255     if (0 == child_st[0])
4256         {
4257 #ifdef ARGPROC_DEBUG
4258         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4259 #endif
4260         fflush(stdout);     /* Have to flush pipe for binary data to    */
4261                             /* terminate properly -- <tp@mccall.com>    */
4262         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4263         sys$dassgn(child_chan);
4264         fclose(stdout);
4265         sys$synch(0, child_st);
4266         }
4267     return(1);
4268 }
4269
4270 static void sig_child(int chan)
4271 {
4272 #ifdef ARGPROC_DEBUG
4273     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4274 #endif
4275     if (child_st[0] == 0)
4276         child_st[0] = 1;
4277 }
4278
4279 static struct exit_control_block exit_block =
4280     {
4281     0,
4282     exit_handler,
4283     1,
4284     &exit_block.exit_status,
4285     0
4286     };
4287
4288 static void
4289 pipe_and_fork(pTHX_ char **cmargv)
4290 {
4291     PerlIO *fp;
4292     struct dsc$descriptor_s *vmscmd;
4293     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4294     int sts, j, l, ismcr, quote, tquote = 0;
4295
4296     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
4297     vms_execfree(vmscmd);
4298
4299     j = l = 0;
4300     p = subcmd;
4301     q = cmargv[0];
4302     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
4303               && toupper(*(q+2)) == 'R' && !*(q+3);
4304
4305     while (q && l < MAX_DCL_LINE_LENGTH) {
4306         if (!*q) {
4307             if (j > 0 && quote) {
4308                 *p++ = '"';
4309                 l++;
4310             }
4311             q = cmargv[++j];
4312             if (q) {
4313                 if (ismcr && j > 1) quote = 1;
4314                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
4315                 *p++ = ' ';
4316                 l++;
4317                 if (quote || tquote) {
4318                     *p++ = '"';
4319                     l++;
4320                 }
4321         }
4322         } else {
4323             if ((quote||tquote) && *q == '"') {
4324                 *p++ = '"';
4325                 l++;
4326         }
4327             *p++ = *q++;
4328             l++;
4329         }
4330     }
4331     *p = '\0';
4332
4333     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4334     if (fp == Nullfp) {
4335         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4336         }
4337 }
4338
4339 static int background_process(pTHX_ int argc, char **argv)
4340 {
4341 char command[2048] = "$";
4342 $DESCRIPTOR(value, "");
4343 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4344 static $DESCRIPTOR(null, "NLA0:");
4345 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4346 char pidstring[80];
4347 $DESCRIPTOR(pidstr, "");
4348 int pid;
4349 unsigned long int flags = 17, one = 1, retsts;
4350
4351     strcat(command, argv[0]);
4352     while (--argc)
4353         {
4354         strcat(command, " \"");
4355         strcat(command, *(++argv));
4356         strcat(command, "\"");
4357         }
4358     value.dsc$a_pointer = command;
4359     value.dsc$w_length = strlen(value.dsc$a_pointer);
4360     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4361     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4362     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4363         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4364     }
4365     else {
4366         _ckvmssts_noperl(retsts);
4367     }
4368 #ifdef ARGPROC_DEBUG
4369     PerlIO_printf(Perl_debug_log, "%s\n", command);
4370 #endif
4371     sprintf(pidstring, "%08X", pid);
4372     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4373     pidstr.dsc$a_pointer = pidstring;
4374     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4375     lib$set_symbol(&pidsymbol, &pidstr);
4376     return(SS$_NORMAL);
4377 }
4378 /*}}}*/
4379 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4380
4381
4382 /* OS-specific initialization at image activation (not thread startup) */
4383 /* Older VAXC header files lack these constants */
4384 #ifndef JPI$_RIGHTS_SIZE
4385 #  define JPI$_RIGHTS_SIZE 817
4386 #endif
4387 #ifndef KGB$M_SUBSYSTEM
4388 #  define KGB$M_SUBSYSTEM 0x8
4389 #endif
4390
4391 /*{{{void vms_image_init(int *, char ***)*/
4392 void
4393 vms_image_init(int *argcp, char ***argvp)
4394 {
4395   char eqv[LNM$C_NAMLENGTH+1] = "";
4396   unsigned int len, tabct = 8, tabidx = 0;
4397   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4398   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4399   unsigned short int dummy, rlen;
4400   struct dsc$descriptor_s **tabvec;
4401 #if defined(PERL_IMPLICIT_CONTEXT)
4402   pTHX = NULL;
4403 #endif
4404   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
4405                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
4406                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4407                                  {          0,                0,    0,      0} };
4408
4409 #ifdef KILL_BY_SIGPRC
4410     (void) Perl_csighandler_init();
4411 #endif
4412
4413   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4414   _ckvmssts_noperl(iosb[0]);
4415   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4416     if (iprv[i]) {           /* Running image installed with privs? */
4417       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
4418       will_taint = TRUE;
4419       break;
4420     }
4421   }
4422   /* Rights identifiers might trigger tainting as well. */
4423   if (!will_taint && (rlen || rsz)) {
4424     while (rlen < rsz) {
4425       /* We didn't get all the identifiers on the first pass.  Allocate a
4426        * buffer much larger than $GETJPI wants (rsz is size in bytes that
4427        * were needed to hold all identifiers at time of last call; we'll
4428        * allocate that many unsigned long ints), and go back and get 'em.
4429        * If it gave us less than it wanted to despite ample buffer space,
4430        * something's broken.  Is your system missing a system identifier?
4431        */
4432       if (rsz <= jpilist[1].buflen) {
4433          /* Perl_croak accvios when used this early in startup. */
4434          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4435                          rsz, (unsigned long) jpilist[1].buflen,
4436                          "Check your rights database for corruption.\n");
4437          exit(SS$_ABORT);
4438       }
4439       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4440       jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4441       jpilist[1].buflen = rsz * sizeof(unsigned long int);
4442       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4443       _ckvmssts_noperl(iosb[0]);
4444     }
4445     mask = jpilist[1].bufadr;
4446     /* Check attribute flags for each identifier (2nd longword); protected
4447      * subsystem identifiers trigger tainting.
4448      */
4449     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4450       if (mask[i] & KGB$M_SUBSYSTEM) {
4451         will_taint = TRUE;
4452         break;
4453       }
4454     }
4455     if (mask != rlst) Safefree(mask);
4456   }
4457   /* We need to use this hack to tell Perl it should run with tainting,
4458    * since its tainting flag may be part of the PL_curinterp struct, which
4459    * hasn't been allocated when vms_image_init() is called.
4460    */
4461   if (will_taint) {
4462     char ***newap;
4463     New(1320,newap,*argcp+2,char **);
4464     newap[0] = argvp[0];
4465     *newap[1] = "-T";
4466     Copy(argvp[1],newap[2],*argcp-1,char **);
4467     /* We orphan the old argv, since we don't know where it's come from,
4468      * so we don't know how to free it.
4469      */
4470     *argcp++; argvp = newap;
4471   }
4472   else {  /* Did user explicitly request tainting? */
4473     int i;
4474     char *cp, **av = *argvp;
4475     for (i = 1; i < *argcp; i++) {
4476       if (*av[i] != '-') break;
4477       for (cp = av[i]+1; *cp; cp++) {
4478         if (*cp == 'T') { will_taint = 1; break; }
4479         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4480                   strchr("DFIiMmx",*cp)) break;
4481       }
4482       if (will_taint) break;
4483     }
4484   }
4485
4486   for (tabidx = 0;
4487        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4488        tabidx++) {
4489     if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4490     else if (tabidx >= tabct) {
4491       tabct += 8;
4492       Renew(tabvec,tabct,struct dsc$descriptor_s *);
4493     }
4494     New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4495     tabvec[tabidx]->dsc$w_length  = 0;
4496     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
4497     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
4498     tabvec[tabidx]->dsc$a_pointer = NULL;
4499     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4500   }
4501   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4502
4503   getredirection(argcp,argvp);
4504 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4505   {
4506 # include <reentrancy.h>
4507   (void) decc$set_reentrancy(C$C_MULTITHREAD);
4508   }
4509 #endif
4510   return;
4511 }
4512 /*}}}*/
4513
4514
4515 /* trim_unixpath()
4516  * Trim Unix-style prefix off filespec, so it looks like what a shell
4517  * glob expansion would return (i.e. from specified prefix on, not
4518  * full path).  Note that returned filespec is Unix-style, regardless
4519  * of whether input filespec was VMS-style or Unix-style.
4520  *
4521  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4522  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
4523  * vector of options; at present, only bit 0 is used, and if set tells
4524  * trim unixpath to try the current default directory as a prefix when
4525  * presented with a possibly ambiguous ... wildcard.
4526  *
4527  * Returns !=0 on success, with trimmed filespec replacing contents of
4528  * fspec, and 0 on failure, with contents of fpsec unchanged.
4529  */
4530 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4531 int
4532 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4533 {
4534   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4535        *template, *base, *end, *cp1, *cp2;
4536   register int tmplen, reslen = 0, dirs = 0;
4537
4538   if (!wildspec || !fspec) return 0;
4539   if (strpbrk(wildspec,"]>:") != NULL) {
4540     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4541     else template = unixwild;
4542   }
4543   else template = wildspec;
4544   if (strpbrk(fspec,"]>:") != NULL) {
4545     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4546     else base = unixified;
4547     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4548      * check to see that final result fits into (isn't longer than) fspec */
4549     reslen = strlen(fspec);
4550   }
4551   else base = fspec;
4552
4553   /* No prefix or absolute path on wildcard, so nothing to remove */
4554   if (!*template || *template == '/') {
4555     if (base == fspec) return 1;
4556     tmplen = strlen(unixified);
4557     if (tmplen > reslen) return 0;  /* not enough space */
4558     /* Copy unixified resultant, including trailing NUL */
4559     memmove(fspec,unixified,tmplen+1);
4560     return 1;
4561   }
4562
4563   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
4564   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4565     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4566     for (cp1 = end ;cp1 >= base; cp1--)
4567       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4568         { cp1++; break; }
4569     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4570     return 1;
4571   }
4572   else {
4573     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4574     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4575     int ells = 1, totells, segdirs, match;
4576     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4577                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4578
4579     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4580     totells = ells;
4581     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4582     if (ellipsis == template && opts & 1) {
4583       /* Template begins with an ellipsis.  Since we can't tell how many
4584        * directory names at the front of the resultant to keep for an
4585        * arbitrary starting point, we arbitrarily choose the current
4586        * default directory as a starting point.  If it's there as a prefix,
4587        * clip it off.  If not, fall through and act as if the leading
4588        * ellipsis weren't there (i.e. return shortest possible path that
4589        * could match template).
4590        */
4591       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4592       for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4593         if (_tolower(*cp1) != _tolower(*cp2)) break;
4594       segdirs = dirs - totells;  /* Min # of dirs we must have left */
4595       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4596       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4597         memcpy(fspec,cp2+1,end - cp2);
4598         return 1;
4599       }
4600     }
4601     /* First off, back up over constant elements at end of path */
4602     if (dirs) {
4603       for (front = end ; front >= base; front--)
4604          if (*front == '/' && !dirs--) { front++; break; }
4605     }
4606     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4607          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
4608     if (cp1 != '\0') return 0;  /* Path too long. */
4609     lcend = cp2;
4610     *cp2 = '\0';  /* Pick up with memcpy later */
4611     lcfront = lcres + (front - base);
4612     /* Now skip over each ellipsis and try to match the path in front of it. */
4613     while (ells--) {
4614       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4615         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
4616             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
4617       if (cp1 < template) break; /* template started with an ellipsis */
4618       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4619         ellipsis = cp1; continue;
4620       }
4621       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4622       nextell = cp1;
4623       for (segdirs = 0, cp2 = tpl;
4624            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4625            cp1++, cp2++) {
4626          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4627          else *cp2 = _tolower(*cp1);  /* else lowercase for match */
4628          if (*cp2 == '/') segdirs++;
4629       }
4630       if (cp1 != ellipsis - 1) return 0; /* Path too long */
4631       /* Back up at least as many dirs as in template before matching */
4632       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4633         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4634       for (match = 0; cp1 > lcres;) {
4635         resdsc.dsc$a_pointer = cp1;
4636         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4637           match++;
4638           if (match == 1) lcfront = cp1;
4639         }
4640         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4641       }
4642       if (!match) return 0;  /* Can't find prefix ??? */
4643       if (match > 1 && opts & 1) {
4644         /* This ... wildcard could cover more than one set of dirs (i.e.
4645          * a set of similar dir names is repeated).  If the template
4646          * contains more than 1 ..., upstream elements could resolve the
4647          * ambiguity, but it's not worth a full backtracking setup here.
4648          * As a quick heuristic, clip off the current default directory
4649          * if it's present to find the trimmed spec, else use the
4650          * shortest string that this ... could cover.
4651          */
4652         char def[NAM$C_MAXRSS+1], *st;
4653
4654         if (getcwd(def, sizeof def,0) == NULL) return 0;
4655         for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4656           if (_tolower(*cp1) != _tolower(*cp2)) break;
4657         segdirs = dirs - totells;  /* Min # of dirs we must have left */
4658         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4659         if (*cp1 == '\0' && *cp2 == '/') {
4660           memcpy(fspec,cp2+1,end - cp2);
4661           return 1;
4662         }
4663         /* Nope -- stick with lcfront from above and keep going. */
4664       }
4665     }
4666     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4667     return 1;
4668     ellipsis = nextell;
4669   }
4670
4671 }  /* end of trim_unixpath() */
4672 /*}}}*/
4673
4674
4675 /*
4676  *  VMS readdir() routines.
4677  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4678  *
4679  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
4680  *  Minor modifications to original routines.
4681  */
4682
4683     /* Number of elements in vms_versions array */
4684 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
4685
4686 /*
4687  *  Open a directory, return a handle for later use.
4688  */
4689 /*{{{ DIR *opendir(char*name) */
4690 DIR *
4691 Perl_opendir(pTHX_ char *name)
4692 {
4693     DIR *dd;
4694     char dir[NAM$C_MAXRSS+1];
4695     Stat_t sb;
4696
4697     if (do_tovmspath(name,dir,0) == NULL) {
4698       return NULL;
4699     }
4700     /* Check access before stat; otherwise stat does not
4701      * accurately report whether it's a directory.
4702      */
4703     if (!cando_by_name(S_IRUSR,0,dir)) {
4704       set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4705       return NULL;
4706     }
4707     if (flex_stat(dir,&sb) == -1) return NULL;
4708     if (!S_ISDIR(sb.st_mode)) {
4709       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
4710       return NULL;
4711     }
4712     /* Get memory for the handle, and the pattern. */
4713     New(1306,dd,1,DIR);
4714     New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4715
4716     /* Fill in the fields; mainly playing with the descriptor. */
4717     (void)sprintf(dd->pattern, "%s*.*",dir);
4718     dd->context = 0;
4719     dd->count = 0;
4720     dd->vms_wantversions = 0;
4721     dd->pat.dsc$a_pointer = dd->pattern;
4722     dd->pat.dsc$w_length = strlen(dd->pattern);
4723     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4724     dd->pat.dsc$b_class = DSC$K_CLASS_S;
4725
4726     return dd;
4727 }  /* end of opendir() */
4728 /*}}}*/
4729
4730 /*
4731  *  Set the flag to indicate we want versions or not.
4732  */
4733 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4734 void
4735 vmsreaddirversions(DIR *dd, int flag)
4736 {
4737     dd->vms_wantversions = flag;
4738 }
4739 /*}}}*/
4740
4741 /*
4742  *  Free up an opened directory.
4743  */
4744 /*{{{ void closedir(DIR *dd)*/
4745 void
4746 closedir(DIR *dd)
4747 {
4748     (void)lib$find_file_end(&dd->context);
4749     Safefree(dd->pattern);
4750     Safefree((char *)dd);
4751 }
4752 /*}}}*/
4753
4754 /*
4755  *  Collect all the version numbers for the current file.
4756  */
4757 static void
4758 collectversions(pTHX_ DIR *dd)
4759 {
4760     struct dsc$descriptor_s     pat;
4761     struct dsc$descriptor_s     res;
4762     struct dirent *e;
4763     char *p, *text, buff[sizeof dd->entry.d_name];
4764     int i;
4765     unsigned long context, tmpsts;
4766
4767     /* Convenient shorthand. */
4768     e = &dd->entry;
4769
4770     /* Add the version wildcard, ignoring the "*.*" put on before */
4771     i = strlen(dd->pattern);
4772     New(1308,text,i + e->d_namlen + 3,char);
4773     (void)strcpy(text, dd->pattern);
4774     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4775
4776     /* Set up the pattern descriptor. */
4777     pat.dsc$a_pointer = text;
4778     pat.dsc$w_length = i + e->d_namlen - 1;
4779     pat.dsc$b_dtype = DSC$K_DTYPE_T;
4780     pat.dsc$b_class = DSC$K_CLASS_S;
4781
4782     /* Set up result descriptor. */
4783     res.dsc$a_pointer = buff;
4784     res.dsc$w_length = sizeof buff - 2;
4785     res.dsc$b_dtype = DSC$K_DTYPE_T;
4786     res.dsc$b_class = DSC$K_CLASS_S;
4787
4788     /* Read files, collecting versions. */
4789     for (context = 0, e->vms_verscount = 0;
4790          e->vms_verscount < VERSIZE(e);
4791          e->vms_verscount++) {
4792         tmpsts = lib$find_file(&pat, &res, &context);
4793         if (tmpsts == RMS$_NMF || context == 0) break;
4794         _ckvmssts(tmpsts);
4795         buff[sizeof buff - 1] = '\0';
4796         if ((p = strchr(buff, ';')))
4797             e->vms_versions[e->vms_verscount] = atoi(p + 1);
4798         else
4799             e->vms_versions[e->vms_verscount] = -1;
4800     }
4801
4802     _ckvmssts(lib$find_file_end(&context));
4803     Safefree(text);
4804
4805 }  /* end of collectversions() */
4806
4807 /*
4808  *  Read the next entry from the directory.
4809  */
4810 /*{{{ struct dirent *readdir(DIR *dd)*/
4811 struct dirent *
4812 Perl_readdir(pTHX_ DIR *dd)
4813 {
4814     struct dsc$descriptor_s     res;
4815     char *p, buff[sizeof dd->entry.d_name];
4816     unsigned long int tmpsts;
4817
4818     /* Set up result descriptor, and get next file. */
4819     res.dsc$a_pointer = buff;
4820     res.dsc$w_length = sizeof buff - 2;
4821     res.dsc$b_dtype = DSC$K_DTYPE_T;
4822     res.dsc$b_class = DSC$K_CLASS_S;
4823     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4824     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
4825     if (!(tmpsts & 1)) {
4826       set_vaxc_errno(tmpsts);
4827       switch (tmpsts) {
4828         case RMS$_PRV:
4829           set_errno(EACCES); break;
4830         case RMS$_DEV:
4831           set_errno(ENODEV); break;
4832         case RMS$_DIR:
4833           set_errno(ENOTDIR); break;
4834         case RMS$_FNF: case RMS$_DNF:
4835           set_errno(ENOENT); break;
4836         default:
4837           set_errno(EVMSERR);
4838       }
4839       return NULL;
4840     }
4841     dd->count++;
4842     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4843     buff[sizeof buff - 1] = '\0';
4844     for (p = buff; *p; p++) *p = _tolower(*p);
4845     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
4846     *p = '\0';
4847
4848     /* Skip any directory component and just copy the name. */
4849     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4850     else (void)strcpy(dd->entry.d_name, buff);
4851
4852     /* Clobber the version. */
4853     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4854
4855     dd->entry.d_namlen = strlen(dd->entry.d_name);
4856     dd->entry.vms_verscount = 0;
4857     if (dd->vms_wantversions) collectversions(aTHX_ dd);
4858     return &dd->entry;
4859
4860 }  /* end of readdir() */
4861 /*}}}*/
4862
4863 /*
4864  *  Return something that can be used in a seekdir later.
4865  */
4866 /*{{{ long telldir(DIR *dd)*/
4867 long
4868 telldir(DIR *dd)
4869 {
4870     return dd->count;
4871 }
4872 /*}}}*/
4873
4874 /*
4875  *  Return to a spot where we used to be.  Brute force.
4876  */
4877 /*{{{ void seekdir(DIR *dd,long count)*/
4878 void
4879 Perl_seekdir(pTHX_ DIR *dd, long count)
4880 {
4881     int vms_wantversions;
4882
4883     /* If we haven't done anything yet... */
4884     if (dd->count == 0)
4885         return;
4886
4887     /* Remember some state, and clear it. */
4888     vms_wantversions = dd->vms_wantversions;
4889     dd->vms_wantversions = 0;
4890     _ckvmssts(lib$find_file_end(&dd->context));
4891     dd->context = 0;
4892
4893     /* The increment is in readdir(). */
4894     for (dd->count = 0; dd->count < count; )
4895         (void)readdir(dd);
4896
4897     dd->vms_wantversions = vms_wantversions;
4898
4899 }  /* end of seekdir() */
4900 /*}}}*/
4901
4902 /* VMS subprocess management
4903  *
4904  * my_vfork() - just a vfork(), after setting a flag to record that
4905  * the current script is trying a Unix-style fork/exec.
4906  *
4907  * vms_do_aexec() and vms_do_exec() are called in response to the
4908  * perl 'exec' function.  If this follows a vfork call, then they
4909  * call out the the regular perl routines in doio.c which do an
4910  * execvp (for those who really want to try this under VMS).
4911  * Otherwise, they do exactly what the perl docs say exec should
4912  * do - terminate the current script and invoke a new command
4913  * (See below for notes on command syntax.)
4914  *
4915  * do_aspawn() and do_spawn() implement the VMS side of the perl
4916  * 'system' function.
4917  *
4918  * Note on command arguments to perl 'exec' and 'system': When handled
4919  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4920  * are concatenated to form a DCL command string.  If the first arg
4921  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4922  * the the command string is handed off to DCL directly.  Otherwise,
4923  * the first token of the command is taken as the filespec of an image
4924  * to run.  The filespec is expanded using a default type of '.EXE' and
4925  * the process defaults for device, directory, etc., and if found, the resultant
4926  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4927  * the command string as parameters.  This is perhaps a bit complicated,
4928  * but I hope it will form a happy medium between what VMS folks expect
4929  * from lib$spawn and what Unix folks expect from exec.
4930  */
4931
4932 static int vfork_called;
4933
4934 /*{{{int my_vfork()*/
4935 int
4936 my_vfork()
4937 {
4938   vfork_called++;
4939   return vfork();
4940 }
4941 /*}}}*/
4942
4943
4944 static void
4945 vms_execfree(struct dsc$descriptor_s *vmscmd)
4946 {
4947   if (vmscmd) {
4948       if (vmscmd->dsc$a_pointer) {
4949           Safefree(vmscmd->dsc$a_pointer);
4950       }
4951       Safefree(vmscmd);
4952   }
4953 }
4954
4955 static char *
4956 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4957 {
4958   char *junk, *tmps = Nullch;
4959   register size_t cmdlen = 0;
4960   size_t rlen;
4961   register SV **idx;
4962   STRLEN n_a;
4963
4964   idx = mark;
4965   if (really) {
4966     tmps = SvPV(really,rlen);
4967     if (*tmps) {
4968       cmdlen += rlen + 1;
4969       idx++;
4970     }
4971   }
4972
4973   for (idx++; idx <= sp; idx++) {
4974     if (*idx) {
4975       junk = SvPVx(*idx,rlen);
4976       cmdlen += rlen ? rlen + 1 : 0;
4977     }
4978   }
4979   New(401,PL_Cmd,cmdlen+1,char);
4980
4981   if (tmps && *tmps) {
4982     strcpy(PL_Cmd,tmps);
4983     mark++;
4984   }
4985   else *PL_Cmd = '\0';
4986   while (++mark <= sp) {
4987     if (*mark) {
4988       char *s = SvPVx(*mark,n_a);
4989       if (!*s) continue;
4990       if (*PL_Cmd) strcat(PL_Cmd," ");
4991       strcat(PL_Cmd,s);
4992     }
4993   }
4994   return PL_Cmd;
4995
4996 }  /* end of setup_argstr() */
4997
4998
4999 static unsigned long int
5000 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5001                    struct dsc$descriptor_s **pvmscmd)
5002 {
5003   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5004   $DESCRIPTOR(defdsc,".EXE");
5005   $DESCRIPTOR(defdsc2,".");
5006   $DESCRIPTOR(resdsc,resspec);
5007   struct dsc$descriptor_s *vmscmd;
5008   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5009   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5010   register char *s, *rest, *cp, *wordbreak;
5011   register int isdcl;
5012
5013   New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5014   vmscmd->dsc$a_pointer = NULL;
5015   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
5016   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
5017   vmscmd->dsc$w_length = 0;
5018   if (pvmscmd) *pvmscmd = vmscmd;
5019
5020   if (suggest_quote) *suggest_quote = 0;
5021
5022   if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5023     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
5024   s = cmd;
5025   while (*s && isspace(*s)) s++;
5026
5027   if (*s == '@' || *s == '$') {
5028     vmsspec[0] = *s;  rest = s + 1;
5029     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5030   }
5031   else { cp = vmsspec; rest = s; }
5032   if (*rest == '.' || *rest == '/') {
5033     char *cp2;
5034     for (cp2 = resspec;
5035          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5036          rest++, cp2++) *cp2 = *rest;
5037     *cp2 = '\0';
5038     if (do_tovmsspec(resspec,cp,0)) {
5039       s = vmsspec;
5040       if (*rest) {
5041         for (cp2 = vmsspec + strlen(vmsspec);
5042              *rest && cp2 - vmsspec < sizeof vmsspec;
5043              rest++, cp2++) *cp2 = *rest;
5044         *cp2 = '\0';
5045       }
5046     }
5047   }
5048   /* Intuit whether verb (first word of cmd) is a DCL command:
5049    *   - if first nonspace char is '@', it's a DCL indirection
5050    * otherwise
5051    *   - if verb contains a filespec separator, it's not a DCL command
5052    *   - if it doesn't, caller tells us whether to default to a DCL
5053    *     command, or to a local image unless told it's DCL (by leading '$')
5054    */
5055   if (*s == '@') {
5056       isdcl = 1;
5057       if (suggest_quote) *suggest_quote = 1;
5058   } else {
5059     register char *filespec = strpbrk(s,":<[.;");
5060     rest = wordbreak = strpbrk(s," \"\t/");
5061     if (!wordbreak) wordbreak = s + strlen(s);
5062     if (*s == '$') check_img = 0;
5063     if (filespec && (filespec < wordbreak)) isdcl = 0;
5064     else isdcl = !check_img;
5065   }
5066
5067   if (!isdcl) {
5068     imgdsc.dsc$a_pointer = s;
5069     imgdsc.dsc$w_length = wordbreak - s;
5070     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5071     if (!(retsts&1)) {
5072         _ckvmssts(lib$find_file_end(&cxt));
5073         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5074     if (!(retsts & 1) && *s == '$') {
5075           _ckvmssts(lib$find_file_end(&cxt));
5076       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5077       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5078           if (!(retsts&1)) {
5079       _ckvmssts(lib$find_file_end(&cxt));
5080             retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5081           }
5082     }
5083     }
5084     _ckvmssts(lib$find_file_end(&cxt));
5085
5086     if (retsts & 1) {
5087       FILE *fp;
5088       s = resspec;
5089       while (*s && !isspace(*s)) s++;
5090       *s = '\0';
5091
5092       /* check that it's really not DCL with no file extension */
5093       fp = fopen(resspec,"r","ctx=bin,shr=get");
5094       if (fp) {
5095         char b[4] = {0,0,0,0};
5096         read(fileno(fp),b,4);
5097         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5098         fclose(fp);
5099       }
5100       if (check_img && isdcl) return RMS$_FNF;
5101
5102       if (cando_by_name(S_IXUSR,0,resspec)) {
5103         New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5104         if (!isdcl) {
5105             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5106             if (suggest_quote) *suggest_quote = 1;
5107         } else {
5108             strcpy(vmscmd->dsc$a_pointer,"@");
5109             if (suggest_quote) *suggest_quote = 1;
5110         }
5111         strcat(vmscmd->dsc$a_pointer,resspec);
5112         if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5113         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5114         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5115       }
5116       else retsts = RMS$_PRV;
5117     }
5118   }
5119   /* It's either a DCL command or we couldn't find a suitable image */
5120   vmscmd->dsc$w_length = strlen(cmd);
5121 /*  if (cmd == PL_Cmd) {
5122       vmscmd->dsc$a_pointer = PL_Cmd;
5123       if (suggest_quote) *suggest_quote = 1;
5124   }
5125   else  */
5126       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5127
5128   /* check if it's a symbol (for quoting purposes) */
5129   if (suggest_quote && !*suggest_quote) {
5130     int iss;
5131     char equiv[LNM$C_NAMLENGTH];
5132     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5133     eqvdsc.dsc$a_pointer = equiv;
5134
5135     iss = lib$get_symbol(vmscmd,&eqvdsc);
5136     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5137   }
5138   if (!(retsts & 1)) {
5139     /* just hand off status values likely to be due to user error */
5140     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5141         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5142        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5143     else { _ckvmssts(retsts); }
5144   }
5145
5146   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5147
5148 }  /* end of setup_cmddsc() */
5149
5150
5151 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5152 bool
5153 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5154 {
5155   if (sp > mark) {
5156     if (vfork_called) {           /* this follows a vfork - act Unixish */
5157       vfork_called--;
5158       if (vfork_called < 0) {
5159         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5160         vfork_called = 0;
5161       }
5162       else return do_aexec(really,mark,sp);
5163     }
5164                                            /* no vfork - act VMSish */
5165     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5166
5167   }
5168
5169   return FALSE;
5170 }  /* end of vms_do_aexec() */
5171 /*}}}*/
5172
5173 /* {{{bool vms_do_exec(char *cmd) */
5174 bool
5175 Perl_vms_do_exec(pTHX_ char *cmd)
5176 {
5177   struct dsc$descriptor_s *vmscmd;
5178
5179   if (vfork_called) {             /* this follows a vfork - act Unixish */
5180     vfork_called--;
5181     if (vfork_called < 0) {
5182       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5183       vfork_called = 0;
5184     }
5185     else return do_exec(cmd);
5186   }
5187
5188   {                               /* no vfork - act VMSish */
5189     unsigned long int retsts;
5190
5191     TAINT_ENV();
5192     TAINT_PROPER("exec");
5193     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5194       retsts = lib$do_command(vmscmd);
5195
5196     switch (retsts) {
5197       case RMS$_FNF: case RMS$_DNF:
5198         set_errno(ENOENT); break;
5199       case RMS$_DIR:
5200         set_errno(ENOTDIR); break;
5201       case RMS$_DEV:
5202         set_errno(ENODEV); break;
5203       case RMS$_PRV:
5204         set_errno(EACCES); break;
5205       case RMS$_SYN:
5206         set_errno(EINVAL); break;
5207       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5208         set_errno(E2BIG); break;
5209       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5210         _ckvmssts(retsts); /* fall through */
5211       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5212         set_errno(EVMSERR);
5213     }
5214     set_vaxc_errno(retsts);
5215     if (ckWARN(WARN_EXEC)) {
5216       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5217              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5218     }
5219     vms_execfree(vmscmd);
5220   }
5221
5222   return FALSE;
5223
5224 }  /* end of vms_do_exec() */
5225 /*}}}*/
5226
5227 unsigned long int Perl_do_spawn(pTHX_ char *);
5228
5229 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5230 unsigned long int
5231 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5232 {
5233   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5234
5235   return SS$_ABORT;
5236 }  /* end of do_aspawn() */
5237 /*}}}*/
5238
5239 /* {{{unsigned long int do_spawn(char *cmd) */
5240 unsigned long int
5241 Perl_do_spawn(pTHX_ char *cmd)
5242 {
5243   unsigned long int sts, substs;
5244
5245   TAINT_ENV();
5246   TAINT_PROPER("spawn");
5247   if (!cmd || !*cmd) {
5248     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5249     if (!(sts & 1)) {
5250       switch (sts) {
5251         case RMS$_FNF:  case RMS$_DNF:
5252           set_errno(ENOENT); break;
5253         case RMS$_DIR:
5254           set_errno(ENOTDIR); break;
5255         case RMS$_DEV:
5256           set_errno(ENODEV); break;
5257         case RMS$_PRV:
5258           set_errno(EACCES); break;
5259         case RMS$_SYN:
5260           set_errno(EINVAL); break;
5261         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5262           set_errno(E2BIG); break;
5263         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5264           _ckvmssts(sts); /* fall through */
5265         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5266           set_errno(EVMSERR);
5267       }
5268       set_vaxc_errno(sts);
5269       if (ckWARN(WARN_EXEC)) {
5270         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5271                     Strerror(errno));
5272       }
5273     }
5274     sts = substs;
5275   }
5276   else {
5277     (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5278   }
5279   return sts;
5280 }  /* end of do_spawn() */
5281 /*}}}*/
5282
5283
5284 static unsigned int *sockflags, sockflagsize;
5285
5286 /*
5287  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5288  * routines found in some versions of the CRTL can't deal with sockets.
5289  * We don't shim the other file open routines since a socket isn't
5290  * likely to be opened by a name.
5291  */
5292 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5293 FILE *my_fdopen(int fd, const char *mode)
5294 {
5295   FILE *fp = fdopen(fd, (char *) mode);
5296
5297   if (fp) {
5298     unsigned int fdoff = fd / sizeof(unsigned int);
5299     struct stat sbuf; /* native stat; we don't need flex_stat */
5300     if (!sockflagsize || fdoff > sockflagsize) {
5301       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
5302       else           New  (1324,sockflags,fdoff+2,unsigned int);
5303       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5304       sockflagsize = fdoff + 2;
5305     }
5306     if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5307       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5308   }
5309   return fp;
5310
5311 }
5312 /*}}}*/
5313
5314
5315 /*
5316  * Clear the corresponding bit when the (possibly) socket stream is closed.
5317  * There still a small hole: we miss an implicit close which might occur
5318  * via freopen().  >> Todo
5319  */
5320 /*{{{ int my_fclose(FILE *fp)*/
5321 int my_fclose(FILE *fp) {
5322   if (fp) {
5323     unsigned int fd = fileno(fp);
5324     unsigned int fdoff = fd / sizeof(unsigned int);
5325
5326     if (sockflagsize && fdoff <= sockflagsize)
5327       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5328   }
5329   return fclose(fp);
5330 }
5331 /*}}}*/
5332
5333
5334 /*
5335  * A simple fwrite replacement which outputs itmsz*nitm chars without
5336  * introducing record boundaries every itmsz chars.
5337  * We are using fputs, which depends on a terminating null.  We may
5338  * well be writing binary data, so we need to accommodate not only
5339  * data with nulls sprinkled in the middle but also data with no null
5340  * byte at the end.
5341  */
5342 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5343 int
5344 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5345 {
5346   register char *cp, *end, *cpd, *data;
5347   register unsigned int fd = fileno(dest);
5348   register unsigned int fdoff = fd / sizeof(unsigned int);
5349   int retval;
5350   int bufsize = itmsz * nitm + 1;
5351
5352   if (fdoff < sockflagsize &&
5353       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5354     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5355     return nitm;
5356   }
5357
5358   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5359   memcpy( data, src, itmsz*nitm );
5360   data[itmsz*nitm] = '\0';
5361
5362   end = data + itmsz * nitm;
5363   retval = (int) nitm; /* on success return # items written */
5364
5365   cpd = data;
5366   while (cpd <= end) {
5367     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5368     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5369     if (cp < end)
5370       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5371     cpd = cp + 1;
5372   }
5373
5374   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5375   return retval;
5376
5377 }  /* end of my_fwrite() */
5378 /*}}}*/
5379
5380 /*{{{ int my_flush(FILE *fp)*/
5381 int
5382 Perl_my_flush(pTHX_ FILE *fp)
5383 {
5384     int res;
5385     if ((res = fflush(fp)) == 0 && fp) {
5386 #ifdef VMS_DO_SOCKETS
5387         Stat_t s;
5388         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5389 #endif
5390             res = fsync(fileno(fp));
5391     }
5392 /*
5393  * If the flush succeeded but set end-of-file, we need to clear
5394  * the error because our caller may check ferror().  BTW, this
5395  * probably means we just flushed an empty file.
5396  */
5397     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5398
5399     return res;
5400 }
5401 /*}}}*/
5402
5403 /*
5404  * Here are replacements for the following Unix routines in the VMS environment:
5405  *      getpwuid    Get information for a particular UIC or UID
5406  *      getpwnam    Get information for a named user
5407  *      getpwent    Get information for each user in the rights database
5408  *      setpwent    Reset search to the start of the rights database
5409  *      endpwent    Finish searching for users in the rights database
5410  *
5411  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5412  * (defined in pwd.h), which contains the following fields:-
5413  *      struct passwd {
5414  *              char        *pw_name;    Username (in lower case)
5415  *              char        *pw_passwd;  Hashed password
5416  *              unsigned int pw_uid;     UIC
5417  *              unsigned int pw_gid;     UIC group  number
5418  *              char        *pw_unixdir; Default device/directory (VMS-style)
5419  *              char        *pw_gecos;   Owner name
5420  *              char        *pw_dir;     Default device/directory (Unix-style)
5421  *              char        *pw_shell;   Default CLI name (eg. DCL)
5422  *      };
5423  * If the specified user does not exist, getpwuid and getpwnam return NULL.
5424  *
5425  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5426  * not the UIC member number (eg. what's returned by getuid()),
5427  * getpwuid() can accept either as input (if uid is specified, the caller's
5428  * UIC group is used), though it won't recognise gid=0.
5429  *
5430  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5431  * information about other users in your group or in other groups, respectively.
5432  * If the required privilege is not available, then these routines fill only
5433  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5434  * string).
5435  *
5436  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5437  */
5438
5439 /* sizes of various UAF record fields */
5440 #define UAI$S_USERNAME 12
5441 #define UAI$S_IDENT    31
5442 #define UAI$S_OWNER    31
5443 #define UAI$S_DEFDEV   31
5444 #define UAI$S_DEFDIR   63
5445 #define UAI$S_DEFCLI   31
5446 #define UAI$S_PWD       8
5447
5448 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
5449                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5450                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
5451
5452 static char __empty[]= "";
5453 static struct passwd __passwd_empty=
5454     {(char *) __empty, (char *) __empty, 0, 0,
5455      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5456 static int contxt= 0;
5457 static struct passwd __pwdcache;
5458 static char __pw_namecache[UAI$S_IDENT+1];
5459
5460 /*
5461  * This routine does most of the work extracting the user information.
5462  */
5463 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5464 {
5465     static struct {
5466         unsigned char length;
5467         char pw_gecos[UAI$S_OWNER+1];
5468     } owner;
5469     static union uicdef uic;
5470     static struct {
5471         unsigned char length;
5472         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5473     } defdev;
5474     static struct {
5475         unsigned char length;
5476         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5477     } defdir;
5478     static struct {
5479         unsigned char length;
5480         char pw_shell[UAI$S_DEFCLI+1];
5481     } defcli;
5482     static char pw_passwd[UAI$S_PWD+1];
5483
5484     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5485     struct dsc$descriptor_s name_desc;
5486     unsigned long int sts;
5487
5488     static struct itmlst_3 itmlst[]= {
5489         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
5490         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
5491         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
5492         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
5493         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
5494         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
5495         {0,                0,           NULL,    NULL}};
5496
5497     name_desc.dsc$w_length=  strlen(name);
5498     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5499     name_desc.dsc$b_class=   DSC$K_CLASS_S;
5500     name_desc.dsc$a_pointer= (char *) name;
5501
5502 /*  Note that sys$getuai returns many fields as counted strings. */
5503     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5504     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5505       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5506     }
5507     else { _ckvmssts(sts); }
5508     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
5509
5510     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
5511     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5512     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5513     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5514     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5515     owner.pw_gecos[lowner]=            '\0';
5516     defdev.pw_dir[ldefdev+ldefdir]= '\0';
5517     defcli.pw_shell[ldefcli]=          '\0';
5518     if (valid_uic(uic)) {
5519         pwd->pw_uid= uic.uic$l_uic;
5520         pwd->pw_gid= uic.uic$v_group;
5521     }
5522     else
5523       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5524     pwd->pw_passwd=  pw_passwd;
5525     pwd->pw_gecos=   owner.pw_gecos;
5526     pwd->pw_dir=     defdev.pw_dir;
5527     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5528     pwd->pw_shell=   defcli.pw_shell;
5529     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5530         int ldir;
5531         ldir= strlen(pwd->pw_unixdir) - 1;
5532         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5533     }
5534     else
5535         strcpy(pwd->pw_unixdir, pwd->pw_dir);
5536     __mystrtolower(pwd->pw_unixdir);
5537     return 1;
5538 }
5539
5540 /*
5541  * Get information for a named user.
5542 */
5543 /*{{{struct passwd *getpwnam(char *name)*/
5544 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5545 {
5546     struct dsc$descriptor_s name_desc;
5547     union uicdef uic;
5548     unsigned long int status, sts;
5549
5550     __pwdcache = __passwd_empty;
5551     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5552       /* We still may be able to determine pw_uid and pw_gid */
5553       name_desc.dsc$w_length=  strlen(name);
5554       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5555       name_desc.dsc$b_class=   DSC$K_CLASS_S;
5556       name_desc.dsc$a_pointer= (char *) name;
5557       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5558         __pwdcache.pw_uid= uic.uic$l_uic;
5559         __pwdcache.pw_gid= uic.uic$v_group;
5560       }
5561       else {
5562         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5563           set_vaxc_errno(sts);
5564           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5565           return NULL;
5566         }
5567         else { _ckvmssts(sts); }
5568       }
5569     }
5570     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5571     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5572     __pwdcache.pw_name= __pw_namecache;
5573     return &__pwdcache;
5574 }  /* end of my_getpwnam() */
5575 /*}}}*/
5576
5577 /*
5578  * Get information for a particular UIC or UID.
5579  * Called by my_getpwent with uid=-1 to list all users.
5580 */
5581 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5582 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5583 {
5584     const $DESCRIPTOR(name_desc,__pw_namecache);
5585     unsigned short lname;
5586     union uicdef uic;
5587     unsigned long int status;
5588
5589     if (uid == (unsigned int) -1) {
5590       do {
5591         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5592         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5593           set_vaxc_errno(status);
5594           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5595           my_endpwent();
5596           return NULL;
5597         }
5598         else { _ckvmssts(status); }
5599       } while (!valid_uic (uic));
5600     }
5601     else {
5602       uic.uic$l_uic= uid;
5603       if (!uic.uic$v_group)
5604         uic.uic$v_group= PerlProc_getgid();
5605       if (valid_uic(uic))
5606         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5607       else status = SS$_IVIDENT;
5608       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5609           status == RMS$_PRV) {
5610         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5611         return NULL;
5612       }
5613       else { _ckvmssts(status); }
5614     }
5615     __pw_namecache[lname]= '\0';
5616     __mystrtolower(__pw_namecache);
5617
5618     __pwdcache = __passwd_empty;
5619     __pwdcache.pw_name = __pw_namecache;
5620
5621 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5622     The identifier's value is usually the UIC, but it doesn't have to be,
5623     so if we can, we let fillpasswd update this. */
5624     __pwdcache.pw_uid =  uic.uic$l_uic;
5625     __pwdcache.pw_gid =  uic.uic$v_group;
5626
5627     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5628     return &__pwdcache;
5629
5630 }  /* end of my_getpwuid() */
5631 /*}}}*/
5632
5633 /*
5634  * Get information for next user.
5635 */
5636 /*{{{struct passwd *my_getpwent()*/
5637 struct passwd *Perl_my_getpwent(pTHX)
5638 {
5639     return (my_getpwuid((unsigned int) -1));
5640 }
5641 /*}}}*/
5642
5643 /*
5644  * Finish searching rights database for users.
5645 */
5646 /*{{{void my_endpwent()*/
5647 void Perl_my_endpwent(pTHX)
5648 {
5649     if (contxt) {
5650       _ckvmssts(sys$finish_rdb(&contxt));
5651       contxt= 0;
5652     }
5653 }
5654 /*}}}*/
5655
5656 #ifdef HOMEGROWN_POSIX_SIGNALS
5657   /* Signal handling routines, pulled into the core from POSIX.xs.
5658    *
5659    * We need these for threads, so they've been rolled into the core,
5660    * rather than left in POSIX.xs.
5661    *
5662    * (DRS, Oct 23, 1997)
5663    */
5664
5665   /* sigset_t is atomic under VMS, so these routines are easy */
5666 /*{{{int my_sigemptyset(sigset_t *) */
5667 int my_sigemptyset(sigset_t *set) {
5668     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5669     *set = 0; return 0;
5670 }
5671 /*}}}*/
5672
5673
5674 /*{{{int my_sigfillset(sigset_t *)*/
5675 int my_sigfillset(sigset_t *set) {
5676     int i;
5677     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5678     for (i = 0; i < NSIG; i++) *set |= (1 << i);
5679     return 0;
5680 }
5681 /*}}}*/
5682
5683
5684 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5685 int my_sigaddset(sigset_t *set, int sig) {
5686     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5687     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5688     *set |= (1 << (sig - 1));
5689     return 0;
5690 }
5691 /*}}}*/
5692
5693
5694 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5695 int my_sigdelset(sigset_t *set, int sig) {
5696     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5697     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5698     *set &= ~(1 << (sig - 1));
5699     return 0;
5700 }
5701 /*}}}*/
5702
5703
5704 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5705 int my_sigismember(sigset_t *set, int sig) {
5706     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5707     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5708     return *set & (1 << (sig - 1));
5709 }
5710 /*}}}*/
5711
5712
5713 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5714 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5715     sigset_t tempmask;
5716
5717     /* If set and oset are both null, then things are badly wrong. Bail out. */
5718     if ((oset == NULL) && (set == NULL)) {
5719       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5720       return -1;
5721     }
5722
5723     /* If set's null, then we're just handling a fetch. */
5724     if (set == NULL) {
5725         tempmask = sigblock(0);
5726     }
5727     else {
5728       switch (how) {
5729       case SIG_SETMASK:
5730         tempmask = sigsetmask(*set);
5731         break;
5732       case SIG_BLOCK:
5733         tempmask = sigblock(*set);
5734         break;
5735       case SIG_UNBLOCK:
5736         tempmask = sigblock(0);
5737         sigsetmask(*oset & ~tempmask);
5738         break;
5739       default:
5740         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5741         return -1;
5742       }
5743     }
5744
5745     /* Did they pass us an oset? If so, stick our holding mask into it */
5746     if (oset)
5747       *oset = tempmask;
5748
5749     return 0;
5750 }
5751 /*}}}*/
5752 #endif  /* HOMEGROWN_POSIX_SIGNALS */
5753
5754
5755 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5756  * my_utime(), and flex_stat(), all of which operate on UTC unless
5757  * VMSISH_TIMES is true.
5758  */
5759 /* method used to handle UTC conversions:
5760  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
5761  */
5762 static int gmtime_emulation_type;
5763 /* number of secs to add to UTC POSIX-style time to get local time */
5764 static long int utc_offset_secs;
5765
5766 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5767  * in vmsish.h.  #undef them here so we can call the CRTL routines
5768  * directly.
5769  */
5770 #undef gmtime
5771 #undef localtime
5772 #undef time
5773
5774
5775 /*
5776  * DEC C previous to 6.0 corrupts the behavior of the /prefix
5777  * qualifier with the extern prefix pragma.  This provisional
5778  * hack circumvents this prefix pragma problem in previous
5779  * precompilers.
5780  */
5781 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5782 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5783 #    pragma __extern_prefix save
5784 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
5785 #    define gmtime decc$__utctz_gmtime
5786 #    define localtime decc$__utctz_localtime
5787 #    define time decc$__utc_time
5788 #    pragma __extern_prefix restore
5789
5790      struct tm *gmtime(), *localtime();
5791
5792 #  endif
5793 #endif
5794
5795
5796 static time_t toutc_dst(time_t loc) {
5797   struct tm *rsltmp;
5798
5799   if ((rsltmp = localtime(&loc)) == NULL) return -1;
5800   loc -= utc_offset_secs;
5801   if (rsltmp->tm_isdst) loc -= 3600;
5802   return loc;
5803 }
5804 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
5805        ((gmtime_emulation_type || my_time(NULL)), \
5806        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5807        ((secs) - utc_offset_secs))))
5808
5809 static time_t toloc_dst(time_t utc) {
5810   struct tm *rsltmp;
5811
5812   utc += utc_offset_secs;
5813   if ((rsltmp = localtime(&utc)) == NULL) return -1;
5814   if (rsltmp->tm_isdst) utc += 3600;
5815   return utc;
5816 }
5817 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
5818        ((gmtime_emulation_type || my_time(NULL)), \
5819        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5820        ((secs) + utc_offset_secs))))
5821
5822 #ifndef RTL_USES_UTC
5823 /*
5824
5825     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
5826         DST starts on 1st sun of april      at 02:00  std time
5827             ends on last sun of october     at 02:00  dst time
5828     see the UCX management command reference, SET CONFIG TIMEZONE
5829     for formatting info.
5830
5831     No, it's not as general as it should be, but then again, NOTHING
5832     will handle UK times in a sensible way.
5833 */
5834
5835
5836 /*
5837     parse the DST start/end info:
5838     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5839 */
5840
5841 static char *
5842 tz_parse_startend(char *s, struct tm *w, int *past)
5843 {
5844     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5845     int ly, dozjd, d, m, n, hour, min, sec, j, k;
5846     time_t g;
5847
5848     if (!s)    return 0;
5849     if (!w) return 0;
5850     if (!past) return 0;
5851
5852     ly = 0;
5853     if (w->tm_year % 4        == 0) ly = 1;
5854     if (w->tm_year % 100      == 0) ly = 0;
5855     if (w->tm_year+1900 % 400 == 0) ly = 1;
5856     if (ly) dinm[1]++;
5857
5858     dozjd = isdigit(*s);
5859     if (*s == 'J' || *s == 'j' || dozjd) {
5860         if (!dozjd && !isdigit(*++s)) return 0;
5861         d = *s++ - '0';
5862         if (isdigit(*s)) {
5863             d = d*10 + *s++ - '0';
5864             if (isdigit(*s)) {
5865                 d = d*10 + *s++ - '0';
5866             }
5867         }
5868         if (d == 0) return 0;
5869         if (d > 366) return 0;
5870         d--;
5871         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
5872         g = d * 86400;
5873         dozjd = 1;
5874     } else if (*s == 'M' || *s == 'm') {
5875         if (!isdigit(*++s)) return 0;
5876         m = *s++ - '0';
5877         if (isdigit(*s)) m = 10*m + *s++ - '0';
5878         if (*s != '.') return 0;
5879         if (!isdigit(*++s)) return 0;
5880         n = *s++ - '0';
5881         if (n < 1 || n > 5) return 0;
5882         if (*s != '.') return 0;
5883         if (!isdigit(*++s)) return 0;
5884         d = *s++ - '0';
5885         if (d > 6) return 0;
5886     }
5887
5888     if (*s == '/') {
5889         if (!isdigit(*++s)) return 0;
5890         hour = *s++ - '0';
5891         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5892         if (*s == ':') {
5893             if (!isdigit(*++s)) return 0;
5894             min = *s++ - '0';
5895             if (isdigit(*s)) min = 10*min + *s++ - '0';
5896             if (*s == ':') {
5897                 if (!isdigit(*++s)) return 0;
5898                 sec = *s++ - '0';
5899                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5900             }
5901         }
5902     } else {
5903         hour = 2;
5904         min = 0;
5905         sec = 0;
5906     }
5907
5908     if (dozjd) {
5909         if (w->tm_yday < d) goto before;
5910         if (w->tm_yday > d) goto after;
5911     } else {
5912         if (w->tm_mon+1 < m) goto before;
5913         if (w->tm_mon+1 > m) goto after;
5914
5915         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
5916         k = d - j; /* mday of first d */
5917         if (k <= 0) k += 7;
5918         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
5919         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5920         if (w->tm_mday < k) goto before;
5921         if (w->tm_mday > k) goto after;
5922     }
5923
5924     if (w->tm_hour < hour) goto before;
5925     if (w->tm_hour > hour) goto after;
5926     if (w->tm_min  < min)  goto before;
5927     if (w->tm_min  > min)  goto after;
5928     if (w->tm_sec  < sec)  goto before;
5929     goto after;
5930
5931 before:
5932     *past = 0;
5933     return s;
5934 after:
5935     *past = 1;
5936     return s;
5937 }
5938
5939
5940
5941
5942 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
5943
5944 static char *
5945 tz_parse_offset(char *s, int *offset)
5946 {
5947     int hour = 0, min = 0, sec = 0;
5948     int neg = 0;
5949     if (!s) return 0;
5950     if (!offset) return 0;
5951
5952     if (*s == '-') {neg++; s++;}
5953     if (*s == '+') s++;
5954     if (!isdigit(*s)) return 0;
5955     hour = *s++ - '0';
5956     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5957     if (hour > 24) return 0;
5958     if (*s == ':') {
5959         if (!isdigit(*++s)) return 0;
5960         min = *s++ - '0';
5961         if (isdigit(*s)) min = min*10 + (*s++ - '0');
5962         if (min > 59) return 0;
5963         if (*s == ':') {
5964             if (!isdigit(*++s)) return 0;
5965             sec = *s++ - '0';
5966             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5967             if (sec > 59) return 0;
5968         }
5969     }
5970
5971     *offset = (hour*60+min)*60 + sec;
5972     if (neg) *offset = -*offset;
5973     return s;
5974 }
5975
5976 /*
5977     input time is w, whatever type of time the CRTL localtime() uses.
5978     sets dst, the zone, and the gmtoff (seconds)
5979
5980     caches the value of TZ and UCX$TZ env variables; note that
5981     my_setenv looks for these and sets a flag if they're changed
5982     for efficiency.
5983
5984     We have to watch out for the "australian" case (dst starts in
5985     october, ends in april)...flagged by "reverse" and checked by
5986     scanning through the months of the previous year.
5987
5988 */
5989
5990 static int
5991 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5992 {
5993     time_t when;
5994     struct tm *w2;
5995     char *s,*s2;
5996     char *dstzone, *tz, *s_start, *s_end;
5997     int std_off, dst_off, isdst;
5998     int y, dststart, dstend;
5999     static char envtz[1025];  /* longer than any logical, symbol, ... */
6000     static char ucxtz[1025];
6001     static char reversed = 0;
6002
6003     if (!w) return 0;
6004
6005     if (tz_updated) {
6006         tz_updated = 0;
6007         reversed = -1;  /* flag need to check  */
6008         envtz[0] = ucxtz[0] = '\0';
6009         tz = my_getenv("TZ",0);
6010         if (tz) strcpy(envtz, tz);
6011         tz = my_getenv("UCX$TZ",0);
6012         if (tz) strcpy(ucxtz, tz);
6013         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
6014     }
6015     tz = envtz;
6016     if (!*tz) tz = ucxtz;
6017
6018     s = tz;
6019     while (isalpha(*s)) s++;
6020     s = tz_parse_offset(s, &std_off);
6021     if (!s) return 0;
6022     if (!*s) {                  /* no DST, hurray we're done! */
6023         isdst = 0;
6024         goto done;
6025     }
6026
6027     dstzone = s;
6028     while (isalpha(*s)) s++;
6029     s2 = tz_parse_offset(s, &dst_off);
6030     if (s2) {
6031         s = s2;
6032     } else {
6033         dst_off = std_off - 3600;
6034     }
6035
6036     if (!*s) {      /* default dst start/end?? */
6037         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
6038             s = strchr(ucxtz,',');
6039         }
6040         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
6041     }
6042     if (*s != ',') return 0;
6043
6044     when = *w;
6045     when = _toutc(when);      /* convert to utc */
6046     when = when - std_off;    /* convert to pseudolocal time*/
6047
6048     w2 = localtime(&when);
6049     y = w2->tm_year;
6050     s_start = s+1;
6051     s = tz_parse_startend(s_start,w2,&dststart);
6052     if (!s) return 0;
6053     if (*s != ',') return 0;
6054
6055     when = *w;
6056     when = _toutc(when);      /* convert to utc */
6057     when = when - dst_off;    /* convert to pseudolocal time*/
6058     w2 = localtime(&when);
6059     if (w2->tm_year != y) {   /* spans a year, just check one time */
6060         when += dst_off - std_off;
6061         w2 = localtime(&when);
6062     }
6063     s_end = s+1;
6064     s = tz_parse_startend(s_end,w2,&dstend);
6065     if (!s) return 0;
6066
6067     if (reversed == -1) {  /* need to check if start later than end */
6068         int j, ds, de;
6069
6070         when = *w;
6071         if (when < 2*365*86400) {
6072             when += 2*365*86400;
6073         } else {
6074             when -= 365*86400;
6075         }
6076         w2 =localtime(&when);
6077         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
6078
6079         for (j = 0; j < 12; j++) {
6080             w2 =localtime(&when);
6081             (void) tz_parse_startend(s_start,w2,&ds);
6082             (void) tz_parse_startend(s_end,w2,&de);
6083             if (ds != de) break;
6084             when += 30*86400;
6085         }
6086         reversed = 0;
6087         if (de && !ds) reversed = 1;
6088     }
6089
6090     isdst = dststart && !dstend;
6091     if (reversed) isdst = dststart  || !dstend;
6092
6093 done:
6094     if (dst)    *dst = isdst;
6095     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6096     if (isdst)  tz = dstzone;
6097     if (zone) {
6098         while(isalpha(*tz))  *zone++ = *tz++;
6099         *zone = '\0';
6100     }
6101     return 1;
6102 }
6103
6104 #endif /* !RTL_USES_UTC */
6105
6106 /* my_time(), my_localtime(), my_gmtime()
6107  * By default traffic in UTC time values, using CRTL gmtime() or
6108  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6109  * Note: We need to use these functions even when the CRTL has working
6110  * UTC support, since they also handle C<use vmsish qw(times);>
6111  *
6112  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
6113  * Modified by Charles Bailey <bailey@newman.upenn.edu>
6114  */
6115
6116 /*{{{time_t my_time(time_t *timep)*/
6117 time_t Perl_my_time(pTHX_ time_t *timep)
6118 {
6119   time_t when;
6120   struct tm *tm_p;
6121
6122   if (gmtime_emulation_type == 0) {
6123     int dstnow;
6124     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
6125                               /* results of calls to gmtime() and localtime() */
6126                               /* for same &base */
6127
6128     gmtime_emulation_type++;
6129     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6130       char off[LNM$C_NAMLENGTH+1];;
6131
6132       gmtime_emulation_type++;
6133       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6134         gmtime_emulation_type++;
6135         utc_offset_secs = 0;
6136         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6137       }
6138       else { utc_offset_secs = atol(off); }
6139     }
6140     else { /* We've got a working gmtime() */
6141       struct tm gmt, local;
6142
6143       gmt = *tm_p;
6144       tm_p = localtime(&base);
6145       local = *tm_p;
6146       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
6147       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6148       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
6149       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
6150     }
6151   }
6152
6153   when = time(NULL);
6154 # ifdef VMSISH_TIME
6155 # ifdef RTL_USES_UTC
6156   if (VMSISH_TIME) when = _toloc(when);
6157 # else
6158   if (!VMSISH_TIME) when = _toutc(when);
6159 # endif
6160 # endif
6161   if (timep != NULL) *timep = when;
6162   return when;
6163
6164 }  /* end of my_time() */
6165 /*}}}*/
6166
6167
6168 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6169 struct tm *
6170 Perl_my_gmtime(pTHX_ const time_t *timep)
6171 {
6172   char *p;
6173   time_t when;
6174   struct tm *rsltmp;
6175
6176   if (timep == NULL) {
6177     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6178     return NULL;
6179   }
6180   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
6181
6182   when = *timep;
6183 # ifdef VMSISH_TIME
6184   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6185 #  endif
6186 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
6187   return gmtime(&when);
6188 # else
6189   /* CRTL localtime() wants local time as input, so does no tz correction */
6190   rsltmp = localtime(&when);
6191   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
6192   return rsltmp;
6193 #endif
6194 }  /* end of my_gmtime() */
6195 /*}}}*/
6196
6197
6198 /*{{{struct tm *my_localtime(const time_t *timep)*/
6199 struct tm *
6200 Perl_my_localtime(pTHX_ const time_t *timep)
6201 {
6202   time_t when, whenutc;
6203   struct tm *rsltmp;
6204   int dst, offset;
6205
6206   if (timep == NULL) {
6207     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6208     return NULL;
6209   }
6210   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
6211   if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6212
6213   when = *timep;
6214 # ifdef RTL_USES_UTC
6215 # ifdef VMSISH_TIME
6216   if (VMSISH_TIME) when = _toutc(when);
6217 # endif
6218   /* CRTL localtime() wants UTC as input, does tz correction itself */
6219   return localtime(&when);
6220
6221 # else /* !RTL_USES_UTC */
6222   whenutc = when;
6223 # ifdef VMSISH_TIME
6224   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
6225   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
6226 # endif
6227   dst = -1;
6228 #ifndef RTL_USES_UTC
6229   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
6230       when = whenutc - offset;                   /* pseudolocal time*/
6231   }
6232 # endif
6233   /* CRTL localtime() wants local time as input, so does no tz correction */
6234   rsltmp = localtime(&when);
6235   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6236   return rsltmp;
6237 # endif
6238
6239 } /*  end of my_localtime() */
6240 /*}}}*/
6241
6242 /* Reset definitions for later calls */
6243 #define gmtime(t)    my_gmtime(t)
6244 #define localtime(t) my_localtime(t)
6245 #define time(t)      my_time(t)
6246
6247
6248 /* my_utime - update modification time of a file
6249  * calling sequence is identical to POSIX utime(), but under
6250  * VMS only the modification time is changed; ODS-2 does not
6251  * maintain access times.  Restrictions differ from the POSIX
6252  * definition in that the time can be changed as long as the
6253  * caller has permission to execute the necessary IO$_MODIFY $QIO;
6254  * no separate checks are made to insure that the caller is the
6255  * owner of the file or has special privs enabled.
6256  * Code here is based on Joe Meadows' FILE utility.
6257  */
6258
6259 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6260  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
6261  * in 100 ns intervals.
6262  */
6263 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6264
6265 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6266 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6267 {
6268   register int i;
6269   long int bintime[2], len = 2, lowbit, unixtime,
6270            secscale = 10000000; /* seconds --> 100 ns intervals */
6271   unsigned long int chan, iosb[2], retsts;
6272   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6273   struct FAB myfab = cc$rms_fab;
6274   struct NAM mynam = cc$rms_nam;
6275 #if defined (__DECC) && defined (__VAX)
6276   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6277    * at least through VMS V6.1, which causes a type-conversion warning.
6278    */
6279 #  pragma message save
6280 #  pragma message disable cvtdiftypes
6281 #endif
6282   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6283   struct fibdef myfib;
6284 #if defined (__DECC) && defined (__VAX)
6285   /* This should be right after the declaration of myatr, but due
6286    * to a bug in VAX DEC C, this takes effect a statement early.
6287    */
6288 #  pragma message restore
6289 #endif
6290   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6291                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6292                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6293
6294   if (file == NULL || *file == '\0') {
6295     set_errno(ENOENT);
6296     set_vaxc_errno(LIB$_INVARG);
6297     return -1;
6298   }
6299   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6300
6301   if (utimes != NULL) {
6302     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
6303      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6304      * Since time_t is unsigned long int, and lib$emul takes a signed long int
6305      * as input, we force the sign bit to be clear by shifting unixtime right
6306      * one bit, then multiplying by an extra factor of 2 in lib$emul().
6307      */
6308     lowbit = (utimes->modtime & 1) ? secscale : 0;
6309     unixtime = (long int) utimes->modtime;
6310 #   ifdef VMSISH_TIME
6311     /* If input was UTC; convert to local for sys svc */
6312     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6313 #   endif
6314     unixtime >>= 1;  secscale <<= 1;
6315     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6316     if (!(retsts & 1)) {
6317       set_errno(EVMSERR);
6318       set_vaxc_errno(retsts);
6319       return -1;
6320     }
6321     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6322     if (!(retsts & 1)) {
6323       set_errno(EVMSERR);
6324       set_vaxc_errno(retsts);
6325       return -1;
6326     }
6327   }
6328   else {
6329     /* Just get the current time in VMS format directly */
6330     retsts = sys$gettim(bintime);
6331     if (!(retsts & 1)) {
6332       set_errno(EVMSERR);
6333       set_vaxc_errno(retsts);
6334       return -1;
6335     }
6336   }
6337
6338   myfab.fab$l_fna = vmsspec;
6339   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6340   myfab.fab$l_nam = &mynam;
6341   mynam.nam$l_esa = esa;
6342   mynam.nam$b_ess = (unsigned char) sizeof esa;
6343   mynam.nam$l_rsa = rsa;
6344   mynam.nam$b_rss = (unsigned char) sizeof rsa;
6345
6346   /* Look for the file to be affected, letting RMS parse the file
6347    * specification for us as well.  I have set errno using only
6348    * values documented in the utime() man page for VMS POSIX.
6349    */
6350   retsts = sys$parse(&myfab,0,0);
6351   if (!(retsts & 1)) {
6352     set_vaxc_errno(retsts);
6353     if      (retsts == RMS$_PRV) set_errno(EACCES);
6354     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6355     else                         set_errno(EVMSERR);
6356     return -1;
6357   }
6358   retsts = sys$search(&myfab,0,0);
6359   if (!(retsts & 1)) {
6360     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6361     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6362     set_vaxc_errno(retsts);
6363     if      (retsts == RMS$_PRV) set_errno(EACCES);
6364     else if (retsts == RMS$_FNF) set_errno(ENOENT);
6365     else                         set_errno(EVMSERR);
6366     return -1;
6367   }
6368
6369   devdsc.dsc$w_length = mynam.nam$b_dev;
6370   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6371
6372   retsts = sys$assign(&devdsc,&chan,0,0);
6373   if (!(retsts & 1)) {
6374     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6375     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6376     set_vaxc_errno(retsts);
6377     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
6378     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
6379     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
6380     else                               set_errno(EVMSERR);
6381     return -1;
6382   }
6383
6384   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6385   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6386
6387   memset((void *) &myfib, 0, sizeof myfib);
6388 #if defined(__DECC) || defined(__DECCXX)
6389   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6390   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6391   /* This prevents the revision time of the file being reset to the current
6392    * time as a result of our IO$_MODIFY $QIO. */
6393   myfib.fib$l_acctl = FIB$M_NORECORD;
6394 #else
6395   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6396   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6397   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6398 #endif
6399   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6400   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6401   myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6402   _ckvmssts(sys$dassgn(chan));
6403   if (retsts & 1) retsts = iosb[0];
6404   if (!(retsts & 1)) {
6405     set_vaxc_errno(retsts);
6406     if (retsts == SS$_NOPRIV) set_errno(EACCES);
6407     else                      set_errno(EVMSERR);
6408     return -1;
6409   }
6410
6411   return 0;
6412 }  /* end of my_utime() */
6413 /*}}}*/
6414
6415 /*
6416  * flex_stat, flex_fstat
6417  * basic stat, but gets it right when asked to stat
6418  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6419  */
6420
6421 /* encode_dev packs a VMS device name string into an integer to allow
6422  * simple comparisons. This can be used, for example, to check whether two
6423  * files are located on the same device, by comparing their encoded device
6424  * names. Even a string comparison would not do, because stat() reuses the
6425  * device name buffer for each call; so without encode_dev, it would be
6426  * necessary to save the buffer and use strcmp (this would mean a number of
6427  * changes to the standard Perl code, to say nothing of what a Perl script
6428  * would have to do.
6429  *
6430  * The device lock id, if it exists, should be unique (unless perhaps compared
6431  * with lock ids transferred from other nodes). We have a lock id if the disk is
6432  * mounted cluster-wide, which is when we tend to get long (host-qualified)
6433  * device names. Thus we use the lock id in preference, and only if that isn't
6434  * available, do we try to pack the device name into an integer (flagged by
6435  * the sign bit (LOCKID_MASK) being set).
6436  *
6437  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6438  * name and its encoded form, but it seems very unlikely that we will find
6439  * two files on different disks that share the same encoded device names,
6440  * and even more remote that they will share the same file id (if the test
6441  * is to check for the same file).
6442  *
6443  * A better method might be to use sys$device_scan on the first call, and to
6444  * search for the device, returning an index into the cached array.
6445  * The number returned would be more intelligable.
6446  * This is probably not worth it, and anyway would take quite a bit longer
6447  * on the first call.
6448  */
6449 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
6450 static mydev_t encode_dev (pTHX_ const char *dev)
6451 {
6452   int i;
6453   unsigned long int f;
6454   mydev_t enc;
6455   char c;
6456   const char *q;
6457
6458   if (!dev || !dev[0]) return 0;
6459
6460 #if LOCKID_MASK
6461   {
6462     struct dsc$descriptor_s dev_desc;
6463     unsigned long int status, lockid, item = DVI$_LOCKID;
6464
6465     /* For cluster-mounted disks, the disk lock identifier is unique, so we
6466        can try that first. */
6467     dev_desc.dsc$w_length =  strlen (dev);
6468     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
6469     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
6470     dev_desc.dsc$a_pointer = (char *) dev;
6471     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6472     if (lockid) return (lockid & ~LOCKID_MASK);
6473   }
6474 #endif
6475
6476   /* Otherwise we try to encode the device name */
6477   enc = 0;
6478   f = 1;
6479   i = 0;
6480   for (q = dev + strlen(dev); q--; q >= dev) {
6481     if (isdigit (*q))
6482       c= (*q) - '0';
6483     else if (isalpha (toupper (*q)))
6484       c= toupper (*q) - 'A' + (char)10;
6485     else
6486       continue; /* Skip '$'s */
6487     i++;
6488     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
6489     if (i>1) f *= 36;
6490     enc += f * (unsigned long int) c;
6491   }
6492   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
6493
6494 }  /* end of encode_dev() */
6495
6496 static char namecache[NAM$C_MAXRSS+1];
6497
6498 static int
6499 is_null_device(name)
6500     const char *name;
6501 {
6502     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6503        The underscore prefix, controller letter, and unit number are
6504        independently optional; for our purposes, the colon punctuation
6505        is not.  The colon can be trailed by optional directory and/or
6506        filename, but two consecutive colons indicates a nodename rather
6507        than a device.  [pr]  */
6508   if (*name == '_') ++name;
6509   if (tolower(*name++) != 'n') return 0;
6510   if (tolower(*name++) != 'l') return 0;
6511   if (tolower(*name) == 'a') ++name;
6512   if (*name == '0') ++name;
6513   return (*name++ == ':') && (*name != ':');
6514 }
6515
6516 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
6517 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6518  * subset of the applicable information.
6519  */
6520 bool
6521 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6522 {
6523   char fname_phdev[NAM$C_MAXRSS+1];
6524   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6525   else {
6526     char fname[NAM$C_MAXRSS+1];
6527     unsigned long int retsts;
6528     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6529                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6530
6531     /* If the struct mystat is stale, we're OOL; stat() overwrites the
6532        device name on successive calls */
6533     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6534     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6535     namdsc.dsc$a_pointer = fname;
6536     namdsc.dsc$w_length = sizeof fname - 1;
6537
6538     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6539                              &namdsc,&namdsc.dsc$w_length,0,0);
6540     if (retsts & 1) {
6541       fname[namdsc.dsc$w_length] = '\0';
6542 /*
6543  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6544  * but if someone has redefined that logical, Perl gets very lost.  Since
6545  * we have the physical device name from the stat buffer, just paste it on.
6546  */
6547       strcpy( fname_phdev, statbufp->st_devnam );
6548       strcat( fname_phdev, strrchr(fname, ':') );
6549
6550       return cando_by_name(bit,effective,fname_phdev);
6551     }
6552     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6553       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6554       return FALSE;
6555     }
6556     _ckvmssts(retsts);
6557     return FALSE;  /* Should never get to here */
6558   }
6559 }  /* end of cando() */
6560 /*}}}*/
6561
6562
6563 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6564 I32
6565 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6566 {
6567   static char usrname[L_cuserid];
6568   static struct dsc$descriptor_s usrdsc =
6569          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6570   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6571   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6572   unsigned short int retlen;
6573   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6574   union prvdef curprv;
6575   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6576          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6577   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6578          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6579          {0,0,0,0}};
6580   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6581          {0,0,0,0}};
6582   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6583
6584   if (!fname || !*fname) return FALSE;
6585   /* Make sure we expand logical names, since sys$check_access doesn't */
6586   if (!strpbrk(fname,"/]>:")) {
6587     strcpy(fileified,fname);
6588     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6589     fname = fileified;
6590   }
6591   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6592   retlen = namdsc.dsc$w_length = strlen(vmsname);
6593   namdsc.dsc$a_pointer = vmsname;
6594   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6595       vmsname[retlen-1] == ':') {
6596     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6597     namdsc.dsc$w_length = strlen(fileified);
6598     namdsc.dsc$a_pointer = fileified;
6599   }
6600
6601   switch (bit) {
6602     case S_IXUSR: case S_IXGRP: case S_IXOTH:
6603       access = ARM$M_EXECUTE; break;
6604     case S_IRUSR: case S_IRGRP: case S_IROTH:
6605       access = ARM$M_READ; break;
6606     case S_IWUSR: case S_IWGRP: case S_IWOTH:
6607       access = ARM$M_WRITE; break;
6608     case S_IDUSR: case S_IDGRP: case S_IDOTH:
6609       access = ARM$M_DELETE; break;
6610     default:
6611       return FALSE;
6612   }
6613
6614   /* Before we call $check_access, create a user profile with the current
6615    * process privs since otherwise it just uses the default privs from the
6616    * UAF and might give false positives or negatives.
6617    */
6618
6619   /* get current process privs and username */
6620   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6621   _ckvmssts(iosb[0]);
6622
6623   /* find out the space required for the profile */
6624   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6625                                     &usrprodsc.dsc$w_length,0));
6626
6627   /* allocate space for the profile and get it filled in */
6628   New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6629   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6630                                     &usrprodsc.dsc$w_length,0));
6631
6632   /* use the profile to check access to the file; free profile & analyze results */
6633   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6634   Safefree(usrprodsc.dsc$a_pointer);
6635   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6636   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
6637       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6638       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6639     set_vaxc_errno(retsts);
6640     if (retsts == SS$_NOPRIV) set_errno(EACCES);
6641     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6642     else set_errno(ENOENT);
6643     return FALSE;
6644   }
6645   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6646     return TRUE;
6647   }
6648   _ckvmssts(retsts);
6649
6650   return FALSE;  /* Should never get here */
6651
6652 }  /* end of cando_by_name() */
6653 /*}}}*/
6654
6655
6656 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6657 int
6658 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6659 {
6660   if (!fstat(fd,(stat_t *) statbufp)) {
6661     if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6662     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6663 #   ifdef RTL_USES_UTC
6664 #   ifdef VMSISH_TIME
6665     if (VMSISH_TIME) {
6666       statbufp->st_mtime = _toloc(statbufp->st_mtime);
6667       statbufp->st_atime = _toloc(statbufp->st_atime);
6668       statbufp->st_ctime = _toloc(statbufp->st_ctime);
6669     }
6670 #   endif
6671 #   else
6672 #   ifdef VMSISH_TIME
6673     if (!VMSISH_TIME) { /* Return UTC instead of local time */
6674 #   else
6675     if (1) {
6676 #   endif
6677       statbufp->st_mtime = _toutc(statbufp->st_mtime);
6678       statbufp->st_atime = _toutc(statbufp->st_atime);
6679       statbufp->st_ctime = _toutc(statbufp->st_ctime);
6680     }
6681 #endif
6682     return 0;
6683   }
6684   return -1;
6685
6686 }  /* end of flex_fstat() */
6687 /*}}}*/
6688
6689 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6690 int
6691 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6692 {
6693     char fileified[NAM$C_MAXRSS+1];
6694     char temp_fspec[NAM$C_MAXRSS+300];
6695     int retval = -1;
6696     int saved_errno, saved_vaxc_errno;
6697
6698     if (!fspec) return retval;
6699     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6700     strcpy(temp_fspec, fspec);
6701     if (statbufp == (Stat_t *) &PL_statcache)
6702       do_tovmsspec(temp_fspec,namecache,0);
6703     if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6704       memset(statbufp,0,sizeof *statbufp);
6705       statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6706       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6707       statbufp->st_uid = 0x00010001;
6708       statbufp->st_gid = 0x0001;
6709       time((time_t *)&statbufp->st_mtime);
6710       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6711       return 0;
6712     }
6713
6714     /* Try for a directory name first.  If fspec contains a filename without
6715      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6716      * and sea:[wine.dark]water. exist, we prefer the directory here.
6717      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6718      * not sea:[wine.dark]., if the latter exists.  If the intended target is
6719      * the file with null type, specify this by calling flex_stat() with
6720      * a '.' at the end of fspec.
6721      */
6722     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6723       retval = stat(fileified,(stat_t *) statbufp);
6724       if (!retval && statbufp == (Stat_t *) &PL_statcache)
6725         strcpy(namecache,fileified);
6726     }
6727     if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6728     if (!retval) {
6729       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6730 #     ifdef RTL_USES_UTC
6731 #     ifdef VMSISH_TIME
6732       if (VMSISH_TIME) {
6733         statbufp->st_mtime = _toloc(statbufp->st_mtime);
6734         statbufp->st_atime = _toloc(statbufp->st_atime);
6735         statbufp->st_ctime = _toloc(statbufp->st_ctime);
6736       }
6737 #     endif
6738 #     else
6739 #     ifdef VMSISH_TIME
6740       if (!VMSISH_TIME) { /* Return UTC instead of local time */
6741 #     else
6742       if (1) {
6743 #     endif
6744         statbufp->st_mtime = _toutc(statbufp->st_mtime);
6745         statbufp->st_atime = _toutc(statbufp->st_atime);
6746         statbufp->st_ctime = _toutc(statbufp->st_ctime);
6747       }
6748 #     endif
6749     }
6750     /* If we were successful, leave errno where we found it */
6751     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6752     return retval;
6753
6754 }  /* end of flex_stat() */
6755 /*}}}*/
6756
6757
6758 /*{{{char *my_getlogin()*/
6759 /* VMS cuserid == Unix getlogin, except calling sequence */
6760 char *
6761 my_getlogin()
6762 {
6763     static char user[L_cuserid];
6764     return cuserid(user);
6765 }
6766 /*}}}*/
6767
6768
6769 /*  rmscopy - copy a file using VMS RMS routines
6770  *
6771  *  Copies contents and attributes of spec_in to spec_out, except owner
6772  *  and protection information.  Name and type of spec_in are used as
6773  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
6774  *  should try to propagate timestamps from the input file to the output file.
6775  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
6776  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
6777  *  propagated to the output file at creation iff the output file specification
6778  *  did not contain an explicit name or type, and the revision date is always
6779  *  updated at the end of the copy operation.  If it is greater than 0, then
6780  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6781  *  other than the revision date should be propagated, and bit 1 indicates
6782  *  that the revision date should be propagated.
6783  *
6784  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6785  *
6786  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6787  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
6788  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
6789  * as part of the Perl standard distribution under the terms of the
6790  * GNU General Public License or the Perl Artistic License.  Copies
6791  * of each may be found in the Perl standard distribution.
6792  */
6793 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6794 int
6795 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6796 {
6797     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6798          rsa[NAM$C_MAXRSS], ubf[32256];
6799     unsigned long int i, sts, sts2;
6800     struct FAB fab_in, fab_out;
6801     struct RAB rab_in, rab_out;
6802     struct NAM nam;
6803     struct XABDAT xabdat;
6804     struct XABFHC xabfhc;
6805     struct XABRDT xabrdt;
6806     struct XABSUM xabsum;
6807
6808     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
6809         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6810       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6811       return 0;
6812     }
6813
6814     fab_in = cc$rms_fab;
6815     fab_in.fab$l_fna = vmsin;
6816     fab_in.fab$b_fns = strlen(vmsin);
6817     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6818     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6819     fab_in.fab$l_fop = FAB$M_SQO;
6820     fab_in.fab$l_nam =  &nam;
6821     fab_in.fab$l_xab = (void *) &xabdat;
6822
6823     nam = cc$rms_nam;
6824     nam.nam$l_rsa = rsa;
6825     nam.nam$b_rss = sizeof(rsa);
6826     nam.nam$l_esa = esa;
6827     nam.nam$b_ess = sizeof (esa);
6828     nam.nam$b_esl = nam.nam$b_rsl = 0;
6829
6830     xabdat = cc$rms_xabdat;        /* To get creation date */
6831     xabdat.xab$l_nxt = (void *) &xabfhc;
6832
6833     xabfhc = cc$rms_xabfhc;        /* To get record length */
6834     xabfhc.xab$l_nxt = (void *) &xabsum;
6835
6836     xabsum = cc$rms_xabsum;        /* To get key and area information */
6837
6838     if (!((sts = sys$open(&fab_in)) & 1)) {
6839       set_vaxc_errno(sts);
6840       switch (sts) {
6841         case RMS$_FNF: case RMS$_DNF:
6842           set_errno(ENOENT); break;
6843         case RMS$_DIR:
6844           set_errno(ENOTDIR); break;
6845         case RMS$_DEV:
6846           set_errno(ENODEV); break;
6847         case RMS$_SYN:
6848           set_errno(EINVAL); break;
6849         case RMS$_PRV:
6850           set_errno(EACCES); break;
6851         default:
6852           set_errno(EVMSERR);
6853       }
6854       return 0;
6855     }
6856
6857     fab_out = fab_in;
6858     fab_out.fab$w_ifi = 0;
6859     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6860     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6861     fab_out.fab$l_fop = FAB$M_SQO;
6862     fab_out.fab$l_fna = vmsout;
6863     fab_out.fab$b_fns = strlen(vmsout);
6864     fab_out.fab$l_dna = nam.nam$l_name;
6865     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6866
6867     if (preserve_dates == 0) {  /* Act like DCL COPY */
6868       nam.nam$b_nop = NAM$M_SYNCHK;
6869       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
6870       if (!((sts = sys$parse(&fab_out)) & 1)) {
6871         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6872         set_vaxc_errno(sts);
6873         return 0;
6874       }
6875       fab_out.fab$l_xab = (void *) &xabdat;
6876       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6877     }
6878     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
6879     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
6880       preserve_dates =0;      /* bitmask from this point forward   */
6881
6882     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6883     if (!((sts = sys$create(&fab_out)) & 1)) {
6884       set_vaxc_errno(sts);
6885       switch (sts) {
6886         case RMS$_DNF:
6887           set_errno(ENOENT); break;
6888         case RMS$_DIR:
6889           set_errno(ENOTDIR); break;
6890         case RMS$_DEV:
6891           set_errno(ENODEV); break;
6892         case RMS$_SYN:
6893           set_errno(EINVAL); break;
6894         case RMS$_PRV:
6895           set_errno(EACCES); break;
6896         default:
6897           set_errno(EVMSERR);
6898       }
6899       return 0;
6900     }
6901     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
6902     if (preserve_dates & 2) {
6903       /* sys$close() will process xabrdt, not xabdat */
6904       xabrdt = cc$rms_xabrdt;
6905 #ifndef __GNUC__
6906       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6907 #else
6908       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6909        * is unsigned long[2], while DECC & VAXC use a struct */
6910       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6911 #endif
6912       fab_out.fab$l_xab = (void *) &xabrdt;
6913     }
6914
6915     rab_in = cc$rms_rab;
6916     rab_in.rab$l_fab = &fab_in;
6917     rab_in.rab$l_rop = RAB$M_BIO;
6918     rab_in.rab$l_ubf = ubf;
6919     rab_in.rab$w_usz = sizeof ubf;
6920     if (!((sts = sys$connect(&rab_in)) & 1)) {
6921       sys$close(&fab_in); sys$close(&fab_out);
6922       set_errno(EVMSERR); set_vaxc_errno(sts);
6923       return 0;
6924     }
6925
6926     rab_out = cc$rms_rab;
6927     rab_out.rab$l_fab = &fab_out;
6928     rab_out.rab$l_rbf = ubf;
6929     if (!((sts = sys$connect(&rab_out)) & 1)) {
6930       sys$close(&fab_in); sys$close(&fab_out);
6931       set_errno(EVMSERR); set_vaxc_errno(sts);
6932       return 0;
6933     }
6934
6935     while ((sts = sys$read(&rab_in))) {  /* always true  */
6936       if (sts == RMS$_EOF) break;
6937       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6938       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6939         sys$close(&fab_in); sys$close(&fab_out);
6940         set_errno(EVMSERR); set_vaxc_errno(sts);
6941         return 0;
6942       }
6943     }
6944
6945     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
6946     sys$close(&fab_in);  sys$close(&fab_out);
6947     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6948     if (!(sts & 1)) {
6949       set_errno(EVMSERR); set_vaxc_errno(sts);
6950       return 0;
6951     }
6952
6953     return 1;
6954
6955 }  /* end of rmscopy() */
6956 /*}}}*/
6957
6958
6959 /***  The following glue provides 'hooks' to make some of the routines
6960  * from this file available from Perl.  These routines are sufficiently
6961  * basic, and are required sufficiently early in the build process,
6962  * that's it's nice to have them available to miniperl as well as the
6963  * full Perl, so they're set up here instead of in an extension.  The
6964  * Perl code which handles importation of these names into a given
6965  * package lives in [.VMS]Filespec.pm in @INC.
6966  */
6967
6968 void
6969 rmsexpand_fromperl(pTHX_ CV *cv)
6970 {
6971   dXSARGS;
6972   char *fspec, *defspec = NULL, *rslt;
6973   STRLEN n_a;
6974
6975   if (!items || items > 2)
6976     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6977   fspec = SvPV(ST(0),n_a);
6978   if (!fspec || !*fspec) XSRETURN_UNDEF;
6979   if (items == 2) defspec = SvPV(ST(1),n_a);
6980
6981   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6982   ST(0) = sv_newmortal();
6983   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6984   XSRETURN(1);
6985 }
6986
6987 void
6988 vmsify_fromperl(pTHX_ CV *cv)
6989 {
6990   dXSARGS;
6991   char *vmsified;
6992   STRLEN n_a;
6993
6994   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6995   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6996   ST(0) = sv_newmortal();
6997   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6998   XSRETURN(1);
6999 }
7000
7001 void
7002 unixify_fromperl(pTHX_ CV *cv)
7003 {
7004   dXSARGS;
7005   char *unixified;
7006   STRLEN n_a;
7007
7008   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7009   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7010   ST(0) = sv_newmortal();
7011   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7012   XSRETURN(1);
7013 }
7014
7015 void
7016 fileify_fromperl(pTHX_ CV *cv)
7017 {
7018   dXSARGS;
7019   char *fileified;
7020   STRLEN n_a;
7021
7022   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7023   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7024   ST(0) = sv_newmortal();
7025   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7026   XSRETURN(1);
7027 }
7028
7029 void
7030 pathify_fromperl(pTHX_ CV *cv)
7031 {
7032   dXSARGS;
7033   char *pathified;
7034   STRLEN n_a;
7035
7036   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7037   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7038   ST(0) = sv_newmortal();
7039   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7040   XSRETURN(1);
7041 }
7042
7043 void
7044 vmspath_fromperl(pTHX_ CV *cv)
7045 {
7046   dXSARGS;
7047   char *vmspath;
7048   STRLEN n_a;
7049
7050   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7051   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7052   ST(0) = sv_newmortal();
7053   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7054   XSRETURN(1);
7055 }
7056
7057 void
7058 unixpath_fromperl(pTHX_ CV *cv)
7059 {
7060   dXSARGS;
7061   char *unixpath;
7062   STRLEN n_a;
7063
7064   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7065   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7066   ST(0) = sv_newmortal();
7067   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7068   XSRETURN(1);
7069 }
7070
7071 void
7072 candelete_fromperl(pTHX_ CV *cv)
7073 {
7074   dXSARGS;
7075   char fspec[NAM$C_MAXRSS+1], *fsp;
7076   SV *mysv;
7077   IO *io;
7078   STRLEN n_a;
7079
7080   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7081
7082   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7083   if (SvTYPE(mysv) == SVt_PVGV) {
7084     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7085       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7086       ST(0) = &PL_sv_no;
7087       XSRETURN(1);
7088     }
7089     fsp = fspec;
7090   }
7091   else {
7092     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7093       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7094       ST(0) = &PL_sv_no;
7095       XSRETURN(1);
7096     }
7097   }
7098
7099   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7100   XSRETURN(1);
7101 }
7102
7103 void
7104 rmscopy_fromperl(pTHX_ CV *cv)
7105 {
7106   dXSARGS;
7107   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7108   int date_flag;
7109   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7110                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7111   unsigned long int sts;
7112   SV *mysv;
7113   IO *io;
7114   STRLEN n_a;
7115
7116   if (items < 2 || items > 3)
7117     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7118
7119   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7120   if (SvTYPE(mysv) == SVt_PVGV) {
7121     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7122       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7123       ST(0) = &PL_sv_no;
7124       XSRETURN(1);
7125     }
7126     inp = inspec;
7127   }
7128   else {
7129     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7130       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7131       ST(0) = &PL_sv_no;
7132       XSRETURN(1);
7133     }
7134   }
7135   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7136   if (SvTYPE(mysv) == SVt_PVGV) {
7137     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7138       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7139       ST(0) = &PL_sv_no;
7140       XSRETURN(1);
7141     }
7142     outp = outspec;
7143   }
7144   else {
7145     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7146       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7147       ST(0) = &PL_sv_no;
7148       XSRETURN(1);
7149     }
7150   }
7151   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7152
7153   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7154   XSRETURN(1);
7155 }
7156
7157
7158 void
7159 mod2fname(pTHX_ CV *cv)
7160 {
7161   dXSARGS;
7162   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7163        workbuff[NAM$C_MAXRSS*1 + 1];
7164   int total_namelen = 3, counter, num_entries;
7165   /* ODS-5 ups this, but we want to be consistent, so... */
7166   int max_name_len = 39;
7167   AV *in_array = (AV *)SvRV(ST(0));
7168
7169   num_entries = av_len(in_array);
7170
7171   /* All the names start with PL_. */
7172   strcpy(ultimate_name, "PL_");
7173
7174   /* Clean up our working buffer */
7175   Zero(work_name, sizeof(work_name), char);
7176
7177   /* Run through the entries and build up a working name */
7178   for(counter = 0; counter <= num_entries; counter++) {
7179     /* If it's not the first name then tack on a __ */
7180     if (counter) {
7181       strcat(work_name, "__");
7182     }
7183     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7184                            PL_na));
7185   }
7186
7187   /* Check to see if we actually have to bother...*/
7188   if (strlen(work_name) + 3 <= max_name_len) {
7189     strcat(ultimate_name, work_name);
7190   } else {
7191     /* It's too darned big, so we need to go strip. We use the same */
7192     /* algorithm as xsubpp does. First, strip out doubled __ */
7193     char *source, *dest, last;
7194     dest = workbuff;
7195     last = 0;
7196     for (source = work_name; *source; source++) {
7197       if (last == *source && last == '_') {
7198         continue;
7199       }
7200       *dest++ = *source;
7201       last = *source;
7202     }
7203     /* Go put it back */
7204     strcpy(work_name, workbuff);
7205     /* Is it still too big? */
7206     if (strlen(work_name) + 3 > max_name_len) {
7207       /* Strip duplicate letters */
7208       last = 0;
7209       dest = workbuff;
7210       for (source = work_name; *source; source++) {
7211         if (last == toupper(*source)) {
7212         continue;
7213         }
7214         *dest++ = *source;
7215         last = toupper(*source);
7216       }
7217       strcpy(work_name, workbuff);
7218     }
7219
7220     /* Is it *still* too big? */
7221     if (strlen(work_name) + 3 > max_name_len) {
7222       /* Too bad, we truncate */
7223       work_name[max_name_len - 2] = 0;
7224     }
7225     strcat(ultimate_name, work_name);
7226   }
7227
7228   /* Okay, return it */
7229   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7230   XSRETURN(1);
7231 }
7232
7233 void
7234 hushexit_fromperl(pTHX_ CV *cv)
7235 {
7236     dXSARGS;
7237
7238     if (items > 0) {
7239         VMSISH_HUSHED = SvTRUE(ST(0));
7240     }
7241     ST(0) = boolSV(VMSISH_HUSHED);
7242     XSRETURN(1);
7243 }
7244
7245 void
7246 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7247                           struct interp_intern *dst)
7248 {
7249     memcpy(dst,src,sizeof(struct interp_intern));
7250 }
7251
7252 void
7253 Perl_sys_intern_clear(pTHX)
7254 {
7255 }
7256
7257 void
7258 Perl_sys_intern_init(pTHX)
7259 {
7260     unsigned int ix = RAND_MAX;
7261     double x;
7262
7263     VMSISH_HUSHED = 0;
7264
7265     x = (float)ix;
7266     MY_INV_RAND_MAX = 1./x;
7267 }
7268
7269 void
7270 init_os_extras()
7271 {
7272   dTHX;
7273   char* file = __FILE__;
7274   char temp_buff[512];
7275   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7276     no_translate_barewords = TRUE;
7277   } else {
7278     no_translate_barewords = FALSE;
7279   }
7280
7281   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7282   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7283   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7284   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7285   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7286   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7287   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7288   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7289   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7290   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7291   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7292
7293   store_pipelocs(aTHX);         /* will redo any earlier attempts */
7294
7295   return;
7296 }
7297
7298 /*  End of vms.c */