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 <accdef.h>
  13 #include <acedef.h>
  14 #include <acldef.h>
  15 #include <armdef.h>
  16 #include <atrdef.h>
  17 #include <chpdef.h>
  18 #include <clidef.h>
  19 #include <climsgdef.h>
  20 #include <descrip.h>
  21 #include <devdef.h>
  22 #include <dvidef.h>
  23 #include <fibdef.h>
  24 #include <float.h>
  25 #include <fscndef.h>
  26 #include <iodef.h>
  27 #include <jpidef.h>
  28 #include <kgbdef.h>
  29 #include <libclidef.h>
  30 #include <libdef.h>
  31 #include <lib$routines.h>
  32 #include <lnmdef.h>
  33 #include <msgdef.h>
  34 #include <prvdef.h>
  35 #include <psldef.h>
  36 #include <rms.h>
  37 #include <shrdef.h>
  38 #include <ssdef.h>
  39 #include <starlet.h>
  40 #include <strdef.h>
  41 #include <str$routines.h>
  42 #include <syidef.h>
  43 #include <uaidef.h>
  44 #include <uicdef.h>
  45
  46 /* Older versions of ssdef.h don't have these */
  47 #ifndef SS$_INVFILFOROP
  48 #  define SS$_INVFILFOROP 3930
  49 #endif
  50 #ifndef SS$_NOSUCHOBJECT
  51 #  define SS$_NOSUCHOBJECT 2696
  52 #endif
  53
  54 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
  55 #define PERLIO_NOT_STDIO 0
  56
  57 /* Don't replace system definitions of vfork, getenv, and stat,
  58  * code below needs to get to the underlying CRTL routines. */
  59 #define DONT_MASK_RTL_CALLS
  60 #include "EXTERN.h"
  61 #include "perl.h"
  62 #include "XSUB.h"
  63 /* Anticipating future expansion in lexical warnings . . . */
  64 #ifndef WARN_INTERNAL
  65 #  define WARN_INTERNAL WARN_MISC
  66 #endif
  67
  68 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
  69 #  define RTL_USES_UTC 1
  70 #endif
  71
  72
  73 /* gcc's header files don't #define direct access macros
  74  * corresponding to VAXC's variant structs */
  75 #ifdef __GNUC__
  76 #  define uic$v_format uic$r_uic_form.uic$v_format
  77 #  define uic$v_group uic$r_uic_form.uic$v_group
  78 #  define uic$v_member uic$r_uic_form.uic$v_member
  79 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
  80 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
  81 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
  82 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
  83 #endif
  84
  85 #if defined(NEED_AN_H_ERRNO)
  86 dEXT int h_errno;
  87 #endif
  88
  89 struct itmlst_3 {
  90   unsigned short int buflen;
  91   unsigned short int itmcode;
  92   void *bufadr;
  93   unsigned short int *retlen;
  94 };
  95
  96 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
  97 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
  98 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
  99 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
 100 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
 101 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
 102 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
 103 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 104 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 105
 106 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 107 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 108
 109 #define MAX_DCL_LINE_LENGTH        255
 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_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
 233                 }
 234 #if defined(USE_5005THREADS)
 235               } else {
 236                   Perl_warner(aTHX_ 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_ 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_ 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_ 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_ 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_ 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_ 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 /* default piping mailbox size */
1096 #define PERL_BUFSIZ        512
1097
1098
1099 static void
1100 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1101 {
1102   unsigned long int mbxbufsiz;
1103   static unsigned long int syssize = 0;
1104   unsigned long int dviitm = DVI$_DEVNAM;
1105   char csize[LNM$C_NAMLENGTH+1];
1106
1107   if (!syssize) {
1108     unsigned long syiitm = SYI$_MAXBUF;
1109     /*
1110      * Get the SYSGEN parameter MAXBUF
1111      *
1112      * If the logical 'PERL_MBX_SIZE' is defined
1113      * use the value of the logical instead of PERL_BUFSIZ, but
1114      * keep the size between 128 and MAXBUF.
1115      *
1116      */
1117     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1118   }
1119
1120   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1121       mbxbufsiz = atoi(csize);
1122   } else {
1123       mbxbufsiz = PERL_BUFSIZ;
1124   }
1125   if (mbxbufsiz < 128) mbxbufsiz = 128;
1126   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1127
1128   _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1129
1130   _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1131   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1132
1133 }  /* end of create_mbx() */
1134
1135
1136 /*{{{  my_popen and my_pclose*/
1137
1138 typedef struct _iosb           IOSB;
1139 typedef struct _iosb*         pIOSB;
1140 typedef struct _pipe           Pipe;
1141 typedef struct _pipe*         pPipe;
1142 typedef struct pipe_details    Info;
1143 typedef struct pipe_details*  pInfo;
1144 typedef struct _srqp            RQE;
1145 typedef struct _srqp*          pRQE;
1146 typedef struct _tochildbuf      CBuf;
1147 typedef struct _tochildbuf*    pCBuf;
1148
1149 struct _iosb {
1150     unsigned short status;
1151     unsigned short count;
1152     unsigned long  dvispec;
1153 };
1154
1155 #pragma member_alignment save
1156 #pragma nomember_alignment quadword
1157 struct _srqp {          /* VMS self-relative queue entry */
1158     unsigned long qptr[2];
1159 };
1160 #pragma member_alignment restore
1161 static RQE  RQE_ZERO = {0,0};
1162
1163 struct _tochildbuf {
1164     RQE             q;
1165     int             eof;
1166     unsigned short  size;
1167     char            *buf;
1168 };
1169
1170 struct _pipe {
1171     RQE            free;
1172     RQE            wait;
1173     int            fd_out;
1174     unsigned short chan_in;
1175     unsigned short chan_out;
1176     char          *buf;
1177     unsigned int   bufsize;
1178     IOSB           iosb;
1179     IOSB           iosb2;
1180     int           *pipe_done;
1181     int            retry;
1182     int            type;
1183     int            shut_on_empty;
1184     int            need_wake;
1185     pPipe         *home;
1186     pInfo          info;
1187     pCBuf          curr;
1188     pCBuf          curr2;
1189 #if defined(PERL_IMPLICIT_CONTEXT)
1190     void            *thx;           /* Either a thread or an interpreter */
1191                                     /* pointer, depending on how we're built */
1192 #endif
1193 };
1194
1195
1196 struct pipe_details
1197 {
1198     pInfo           next;
1199     PerlIO *fp;  /* file pointer to pipe mailbox */
1200     int useFILE; /* using stdio, not perlio */
1201     int pid;   /* PID of subprocess */
1202     int mode;  /* == 'r' if pipe open for reading */
1203     int done;  /* subprocess has completed */
1204     int waiting; /* waiting for completion/closure */
1205     int             closing;        /* my_pclose is closing this pipe */
1206     unsigned long   completion;     /* termination status of subprocess */
1207     pPipe           in;             /* pipe in to sub */
1208     pPipe           out;            /* pipe out of sub */
1209     pPipe           err;            /* pipe of sub's sys$error */
1210     int             in_done;        /* true when in pipe finished */
1211     int             out_done;
1212     int             err_done;
1213 };
1214
1215 struct exit_control_block
1216 {
1217     struct exit_control_block *flink;
1218     unsigned long int   (*exit_routine)();
1219     unsigned long int arg_count;
1220     unsigned long int *status_address;
1221     unsigned long int exit_status;
1222 };
1223
1224 #define RETRY_DELAY     "0 ::0.20"
1225 #define MAX_RETRY              50
1226
1227 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
1228 static unsigned long mypid;
1229 static unsigned long delaytime[2];
1230
1231 static pInfo open_pipes = NULL;
1232 static $DESCRIPTOR(nl_desc, "NL:");
1233
1234 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
1235
1236
1237
1238 static unsigned long int
1239 pipe_exit_routine(pTHX)
1240 {
1241     pInfo info;
1242     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1243     int sts, did_stuff, need_eof, j;
1244
1245     /*
1246         flush any pending i/o
1247     */
1248     info = open_pipes;
1249     while (info) {
1250         if (info->fp) {
1251            if (!info->useFILE)
1252                PerlIO_flush(info->fp);   /* first, flush data */
1253            else
1254                fflush((FILE *)info->fp);
1255         }
1256         info = info->next;
1257     }
1258
1259     /*
1260      next we try sending an EOF...ignore if doesn't work, make sure we
1261      don't hang
1262     */
1263     did_stuff = 0;
1264     info = open_pipes;
1265
1266     while (info) {
1267       int need_eof;
1268       _ckvmssts(sys$setast(0));
1269       if (info->in && !info->in->shut_on_empty) {
1270         _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1271                           0, 0, 0, 0, 0, 0));
1272         info->waiting = 1;
1273         did_stuff = 1;
1274       }
1275       _ckvmssts(sys$setast(1));
1276       info = info->next;
1277     }
1278
1279     /* wait for EOF to have effect, up to ~ 30 sec [default] */
1280
1281     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1282         int nwait = 0;
1283
1284         info = open_pipes;
1285         while (info) {
1286           _ckvmssts(sys$setast(0));
1287           if (info->waiting && info->done)
1288                 info->waiting = 0;
1289           nwait += info->waiting;
1290           _ckvmssts(sys$setast(1));
1291           info = info->next;
1292         }
1293         if (!nwait) break;
1294         sleep(1);
1295     }
1296
1297     did_stuff = 0;
1298     info = open_pipes;
1299     while (info) {
1300       _ckvmssts(sys$setast(0));
1301       if (!info->done) { /* Tap them gently on the shoulder . . .*/
1302         sts = sys$forcex(&info->pid,0,&abort);
1303         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1304         did_stuff = 1;
1305       }
1306       _ckvmssts(sys$setast(1));
1307       info = info->next;
1308     }
1309
1310     /* again, wait for effect */
1311
1312     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1313         int nwait = 0;
1314
1315         info = open_pipes;
1316         while (info) {
1317           _ckvmssts(sys$setast(0));
1318           if (info->waiting && info->done)
1319                 info->waiting = 0;
1320           nwait += info->waiting;
1321           _ckvmssts(sys$setast(1));
1322           info = info->next;
1323         }
1324         if (!nwait) break;
1325         sleep(1);
1326     }
1327
1328     info = open_pipes;
1329     while (info) {
1330       _ckvmssts(sys$setast(0));
1331       if (!info->done) {  /* We tried to be nice . . . */
1332         sts = sys$delprc(&info->pid,0);
1333         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1334       }
1335       _ckvmssts(sys$setast(1));
1336       info = info->next;
1337     }
1338
1339     while(open_pipes) {
1340       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1341       else if (!(sts & 1)) retsts = sts;
1342     }
1343     return retsts;
1344 }
1345
1346 static struct exit_control_block pipe_exitblock =
1347        {(struct exit_control_block *) 0,
1348         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1349
1350 static void pipe_mbxtofd_ast(pPipe p);
1351 static void pipe_tochild1_ast(pPipe p);
1352 static void pipe_tochild2_ast(pPipe p);
1353
1354 static void
1355 popen_completion_ast(pInfo info)
1356 {
1357   pInfo i = open_pipes;
1358   int iss;
1359
1360   while (i) {
1361     if (i == info) break;
1362     i = i->next;
1363   }
1364   if (!i) return;       /* unlinked, probably freed too */
1365
1366   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1367   info->done = TRUE;
1368
1369 /*
1370     Writing to subprocess ...
1371             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1372
1373             chan_out may be waiting for "done" flag, or hung waiting
1374             for i/o completion to child...cancel the i/o.  This will
1375             put it into "snarf mode" (done but no EOF yet) that discards
1376             input.
1377
1378     Output from subprocess (stdout, stderr) needs to be flushed and
1379     shut down.   We try sending an EOF, but if the mbx is full the pipe
1380     routine should still catch the "shut_on_empty" flag, telling it to
1381     use immediate-style reads so that "mbx empty" -> EOF.
1382
1383
1384 */
1385   if (info->in && !info->in_done) {               /* only for mode=w */
1386         if (info->in->shut_on_empty && info->in->need_wake) {
1387             info->in->need_wake = FALSE;
1388             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1389         } else {
1390             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1391         }
1392   }
1393
1394   if (info->out && !info->out_done) {             /* were we also piping output? */
1395       info->out->shut_on_empty = TRUE;
1396       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1397       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1398       _ckvmssts_noperl(iss);
1399   }
1400
1401   if (info->err && !info->err_done) {        /* we were piping stderr */
1402         info->err->shut_on_empty = TRUE;
1403         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1404         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1405         _ckvmssts_noperl(iss);
1406   }
1407   _ckvmssts_noperl(sys$setef(pipe_ef));
1408
1409 }
1410
1411 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote);
1412 static void vms_execfree(pTHX);
1413
1414 /*
1415     we actually differ from vmstrnenv since we use this to
1416     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1417     are pointing to the same thing
1418 */
1419
1420 static unsigned short
1421 popen_translate(pTHX_ char *logical, char *result)
1422 {
1423     int iss;
1424     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1425     $DESCRIPTOR(d_log,"");
1426     struct _il3 {
1427         unsigned short length;
1428         unsigned short code;
1429         char *         buffer_addr;
1430         unsigned short *retlenaddr;
1431     } itmlst[2];
1432     unsigned short l, ifi;
1433
1434     d_log.dsc$a_pointer = logical;
1435     d_log.dsc$w_length  = strlen(logical);
1436
1437     itmlst[0].code = LNM$_STRING;
1438     itmlst[0].length = 255;
1439     itmlst[0].buffer_addr = result;
1440     itmlst[0].retlenaddr = &l;
1441
1442     itmlst[1].code = 0;
1443     itmlst[1].length = 0;
1444     itmlst[1].buffer_addr = 0;
1445     itmlst[1].retlenaddr = 0;
1446
1447     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1448     if (iss == SS$_NOLOGNAM) {
1449         iss = SS$_NORMAL;
1450         l = 0;
1451     }
1452     if (!(iss&1)) lib$signal(iss);
1453     result[l] = '\0';
1454 /*
1455     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
1456     strip it off and return the ifi, if any
1457 */
1458     ifi  = 0;
1459     if (result[0] == 0x1b && result[1] == 0x00) {
1460         memcpy(&ifi,result+2,2);
1461         strcpy(result,result+4);
1462     }
1463     return ifi;     /* this is the RMS internal file id */
1464 }
1465
1466 #define MAX_DCL_SYMBOL        255
1467 static void pipe_infromchild_ast(pPipe p);
1468
1469 /*
1470     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1471     inside an AST routine without worrying about reentrancy and which Perl
1472     memory allocator is being used.
1473
1474     We read data and queue up the buffers, then spit them out one at a
1475     time to the output mailbox when the output mailbox is ready for one.
1476
1477 */
1478 #define INITIAL_TOCHILDQUEUE  2
1479
1480 static pPipe
1481 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1482 {
1483     pPipe p;
1484     pCBuf b;
1485     char mbx1[64], mbx2[64];
1486     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1487                                       DSC$K_CLASS_S, mbx1},
1488                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1489                                       DSC$K_CLASS_S, mbx2};
1490     unsigned int dviitm = DVI$_DEVBUFSIZ;
1491     int j, n;
1492
1493     New(1368, p, 1, Pipe);
1494
1495     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1496     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1497     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1498
1499     p->buf           = 0;
1500     p->shut_on_empty = FALSE;
1501     p->need_wake     = FALSE;
1502     p->type          = 0;
1503     p->retry         = 0;
1504     p->iosb.status   = SS$_NORMAL;
1505     p->iosb2.status  = SS$_NORMAL;
1506     p->free          = RQE_ZERO;
1507     p->wait          = RQE_ZERO;
1508     p->curr          = 0;
1509     p->curr2         = 0;
1510     p->info          = 0;
1511 #ifdef PERL_IMPLICIT_CONTEXT
1512     p->thx           = aTHX;
1513 #endif
1514
1515     n = sizeof(CBuf) + p->bufsize;
1516
1517     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1518         _ckvmssts(lib$get_vm(&n, &b));
1519         b->buf = (char *) b + sizeof(CBuf);
1520         _ckvmssts(lib$insqhi(b, &p->free));
1521     }
1522
1523     pipe_tochild2_ast(p);
1524     pipe_tochild1_ast(p);
1525     strcpy(wmbx, mbx1);
1526     strcpy(rmbx, mbx2);
1527     return p;
1528 }
1529
1530 /*  reads the MBX Perl is writing, and queues */
1531
1532 static void
1533 pipe_tochild1_ast(pPipe p)
1534 {
1535     pCBuf b = p->curr;
1536     int iss = p->iosb.status;
1537     int eof = (iss == SS$_ENDOFFILE);
1538 #ifdef PERL_IMPLICIT_CONTEXT
1539     pTHX = p->thx;
1540 #endif
1541
1542     if (p->retry) {
1543         if (eof) {
1544             p->shut_on_empty = TRUE;
1545             b->eof     = TRUE;
1546             _ckvmssts(sys$dassgn(p->chan_in));
1547         } else  {
1548             _ckvmssts(iss);
1549         }
1550
1551         b->eof  = eof;
1552         b->size = p->iosb.count;
1553         _ckvmssts(lib$insqhi(b, &p->wait));
1554         if (p->need_wake) {
1555             p->need_wake = FALSE;
1556             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1557         }
1558     } else {
1559         p->retry = 1;   /* initial call */
1560     }
1561
1562     if (eof) {                  /* flush the free queue, return when done */
1563         int n = sizeof(CBuf) + p->bufsize;
1564         while (1) {
1565             iss = lib$remqti(&p->free, &b);
1566             if (iss == LIB$_QUEWASEMP) return;
1567             _ckvmssts(iss);
1568             _ckvmssts(lib$free_vm(&n, &b));
1569         }
1570     }
1571
1572     iss = lib$remqti(&p->free, &b);
1573     if (iss == LIB$_QUEWASEMP) {
1574         int n = sizeof(CBuf) + p->bufsize;
1575         _ckvmssts(lib$get_vm(&n, &b));
1576         b->buf = (char *) b + sizeof(CBuf);
1577     } else {
1578        _ckvmssts(iss);
1579     }
1580
1581     p->curr = b;
1582     iss = sys$qio(0,p->chan_in,
1583              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1584              &p->iosb,
1585              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1586     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1587     _ckvmssts(iss);
1588 }
1589
1590
1591 /* writes queued buffers to output, waits for each to complete before
1592    doing the next */
1593
1594 static void
1595 pipe_tochild2_ast(pPipe p)
1596 {
1597     pCBuf b = p->curr2;
1598     int iss = p->iosb2.status;
1599     int n = sizeof(CBuf) + p->bufsize;
1600     int done = (p->info && p->info->done) ||
1601               iss == SS$_CANCEL || iss == SS$_ABORT;
1602 #if defined(PERL_IMPLICIT_CONTEXT)
1603     pTHX = p->thx;
1604 #endif
1605
1606     do {
1607         if (p->type) {         /* type=1 has old buffer, dispose */
1608             if (p->shut_on_empty) {
1609                 _ckvmssts(lib$free_vm(&n, &b));
1610             } else {
1611                 _ckvmssts(lib$insqhi(b, &p->free));
1612             }
1613             p->type = 0;
1614         }
1615
1616         iss = lib$remqti(&p->wait, &b);
1617         if (iss == LIB$_QUEWASEMP) {
1618             if (p->shut_on_empty) {
1619                 if (done) {
1620                     _ckvmssts(sys$dassgn(p->chan_out));
1621                     *p->pipe_done = TRUE;
1622                     _ckvmssts(sys$setef(pipe_ef));
1623                 } else {
1624                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1625                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1626                 }
1627                 return;
1628             }
1629             p->need_wake = TRUE;
1630             return;
1631         }
1632         _ckvmssts(iss);
1633         p->type = 1;
1634     } while (done);
1635
1636
1637     p->curr2 = b;
1638     if (b->eof) {
1639         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1640             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1641     } else {
1642         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1643             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1644     }
1645
1646     return;
1647
1648 }
1649
1650
1651 static pPipe
1652 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1653 {
1654     pPipe p;
1655     char mbx1[64], mbx2[64];
1656     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1657                                       DSC$K_CLASS_S, mbx1},
1658                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1659                                       DSC$K_CLASS_S, mbx2};
1660     unsigned int dviitm = DVI$_DEVBUFSIZ;
1661
1662     New(1367, p, 1, Pipe);
1663     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1664     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1665
1666     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1667     New(1367, p->buf, p->bufsize, char);
1668     p->shut_on_empty = FALSE;
1669     p->info   = 0;
1670     p->type   = 0;
1671     p->iosb.status = SS$_NORMAL;
1672 #if defined(PERL_IMPLICIT_CONTEXT)
1673     p->thx = aTHX;
1674 #endif
1675     pipe_infromchild_ast(p);
1676
1677     strcpy(wmbx, mbx1);
1678     strcpy(rmbx, mbx2);
1679     return p;
1680 }
1681
1682 static void
1683 pipe_infromchild_ast(pPipe p)
1684 {
1685     int iss = p->iosb.status;
1686     int eof = (iss == SS$_ENDOFFILE);
1687     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1688     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1689 #if defined(PERL_IMPLICIT_CONTEXT)
1690     pTHX = p->thx;
1691 #endif
1692
1693     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
1694         _ckvmssts(sys$dassgn(p->chan_out));
1695         p->chan_out = 0;
1696     }
1697
1698     /* read completed:
1699             input shutdown if EOF from self (done or shut_on_empty)
1700             output shutdown if closing flag set (my_pclose)
1701             send data/eof from child or eof from self
1702             otherwise, re-read (snarf of data from child)
1703     */
1704
1705     if (p->type == 1) {
1706         p->type = 0;
1707         if (myeof && p->chan_in) {                  /* input shutdown */
1708             _ckvmssts(sys$dassgn(p->chan_in));
1709             p->chan_in = 0;
1710         }
1711
1712         if (p->chan_out) {
1713             if (myeof || kideof) {      /* pass EOF to parent */
1714                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1715                               pipe_infromchild_ast, p,
1716                               0, 0, 0, 0, 0, 0));
1717                 return;
1718             } else if (eof) {       /* eat EOF --- fall through to read*/
1719
1720             } else {                /* transmit data */
1721                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1722                               pipe_infromchild_ast,p,
1723                               p->buf, p->iosb.count, 0, 0, 0, 0));
1724                 return;
1725             }
1726         }
1727     }
1728
1729     /*  everything shut? flag as done */
1730
1731     if (!p->chan_in && !p->chan_out) {
1732         *p->pipe_done = TRUE;
1733         _ckvmssts(sys$setef(pipe_ef));
1734         return;
1735     }
1736
1737     /* write completed (or read, if snarfing from child)
1738             if still have input active,
1739                queue read...immediate mode if shut_on_empty so we get EOF if empty
1740             otherwise,
1741                check if Perl reading, generate EOFs as needed
1742     */
1743
1744     if (p->type == 0) {
1745         p->type = 1;
1746         if (p->chan_in) {
1747             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1748                           pipe_infromchild_ast,p,
1749                           p->buf, p->bufsize, 0, 0, 0, 0);
1750             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1751             _ckvmssts(iss);
1752         } else {           /* send EOFs for extra reads */
1753             p->iosb.status = SS$_ENDOFFILE;
1754             p->iosb.dvispec = 0;
1755             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1756                       0, 0, 0,
1757                       pipe_infromchild_ast, p, 0, 0, 0, 0));
1758         }
1759     }
1760 }
1761
1762 static pPipe
1763 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1764 {
1765     pPipe p;
1766     char mbx[64];
1767     unsigned long dviitm = DVI$_DEVBUFSIZ;
1768     struct stat s;
1769     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1770                                       DSC$K_CLASS_S, mbx};
1771
1772     /* things like terminals and mbx's don't need this filter */
1773     if (fd && fstat(fd,&s) == 0) {
1774         unsigned long dviitm = DVI$_DEVCHAR, devchar;
1775         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1776                                          DSC$K_CLASS_S, s.st_dev};
1777
1778         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1779         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
1780             strcpy(out, s.st_dev);
1781             return 0;
1782         }
1783     }
1784
1785     New(1366, p, 1, Pipe);
1786     p->fd_out = dup(fd);
1787     create_mbx(aTHX_ &p->chan_in, &d_mbx);
1788     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1789     New(1366, p->buf, p->bufsize+1, char);
1790     p->shut_on_empty = FALSE;
1791     p->retry = 0;
1792     p->info  = 0;
1793     strcpy(out, mbx);
1794
1795     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1796                   pipe_mbxtofd_ast, p,
1797                   p->buf, p->bufsize, 0, 0, 0, 0));
1798
1799     return p;
1800 }
1801
1802 static void
1803 pipe_mbxtofd_ast(pPipe p)
1804 {
1805     int iss = p->iosb.status;
1806     int done = p->info->done;
1807     int iss2;
1808     int eof = (iss == SS$_ENDOFFILE);
1809     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1810     int err = !(iss&1) && !eof;
1811 #if defined(PERL_IMPLICIT_CONTEXT)
1812     pTHX = p->thx;
1813 #endif
1814
1815     if (done && myeof) {               /* end piping */
1816         close(p->fd_out);
1817         sys$dassgn(p->chan_in);
1818         *p->pipe_done = TRUE;
1819         _ckvmssts(sys$setef(pipe_ef));
1820         return;
1821     }
1822
1823     if (!err && !eof) {             /* good data to send to file */
1824         p->buf[p->iosb.count] = '\n';
1825         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1826         if (iss2 < 0) {
1827             p->retry++;
1828             if (p->retry < MAX_RETRY) {
1829                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1830                 return;
1831             }
1832         }
1833         p->retry = 0;
1834     } else if (err) {
1835         _ckvmssts(iss);
1836     }
1837
1838
1839     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1840           pipe_mbxtofd_ast, p,
1841           p->buf, p->bufsize, 0, 0, 0, 0);
1842     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1843     _ckvmssts(iss);
1844 }
1845
1846
1847 typedef struct _pipeloc     PLOC;
1848 typedef struct _pipeloc*   pPLOC;
1849
1850 struct _pipeloc {
1851     pPLOC   next;
1852     char    dir[NAM$C_MAXRSS+1];
1853 };
1854 static pPLOC  head_PLOC = 0;
1855
1856 void
1857 free_pipelocs(pTHX_ void *head)
1858 {
1859     pPLOC p, pnext;
1860     pPLOC *pHead = (pPLOC *)head;
1861
1862     p = *pHead;
1863     while (p) {
1864         pnext = p->next;
1865         Safefree(p);
1866         p = pnext;
1867     }
1868     *pHead = 0;
1869 }
1870
1871 static void
1872 store_pipelocs(pTHX)
1873 {
1874     int    i;
1875     pPLOC  p;
1876     AV    *av = 0;
1877     SV    *dirsv;
1878     GV    *gv;
1879     char  *dir, *x;
1880     char  *unixdir;
1881     char  temp[NAM$C_MAXRSS+1];
1882     STRLEN n_a;
1883
1884     if (head_PLOC)
1885         free_pipelocs(&head_PLOC);
1886
1887 /*  the . directory from @INC comes last */
1888
1889     New(1370,p,1,PLOC);
1890     p->next = head_PLOC;
1891     head_PLOC = p;
1892     strcpy(p->dir,"./");
1893
1894 /*  get the directory from $^X */
1895
1896     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
1897         strcpy(temp, PL_origargv[0]);
1898         x = strrchr(temp,']');
1899         if (x) x[1] = '\0';
1900
1901         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1902             New(1370,p,1,PLOC);
1903             p->next = head_PLOC;
1904             head_PLOC = p;
1905             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1906             p->dir[NAM$C_MAXRSS] = '\0';
1907         }
1908     }
1909
1910 /*  reverse order of @INC entries, skip "." since entered above */
1911
1912     if (PL_incgv) av = GvAVn(PL_incgv);
1913
1914     for (i = 0; av && i <= AvFILL(av); i++) {
1915         dirsv = *av_fetch(av,i,TRUE);
1916
1917         if (SvROK(dirsv)) continue;
1918         dir = SvPVx(dirsv,n_a);
1919         if (strcmp(dir,".") == 0) continue;
1920         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1921             continue;
1922
1923         New(1370,p,1,PLOC);
1924         p->next = head_PLOC;
1925         head_PLOC = p;
1926         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1927         p->dir[NAM$C_MAXRSS] = '\0';
1928     }
1929
1930 /* most likely spot (ARCHLIB) put first in the list */
1931
1932 #ifdef ARCHLIB_EXP
1933     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1934         New(1370,p,1,PLOC);
1935         p->next = head_PLOC;
1936         head_PLOC = p;
1937         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1938         p->dir[NAM$C_MAXRSS] = '\0';
1939     }
1940 #endif
1941     Perl_call_atexit(aTHX_ &free_pipelocs, &head_PLOC);
1942 }
1943
1944
1945 static char *
1946 find_vmspipe(pTHX)
1947 {
1948     static int   vmspipe_file_status = 0;
1949     static char  vmspipe_file[NAM$C_MAXRSS+1];
1950
1951     /* already found? Check and use ... need read+execute permission */
1952
1953     if (vmspipe_file_status == 1) {
1954         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1955          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1956             return vmspipe_file;
1957         }
1958         vmspipe_file_status = 0;
1959     }
1960
1961     /* scan through stored @INC, $^X */
1962
1963     if (vmspipe_file_status == 0) {
1964         char file[NAM$C_MAXRSS+1];
1965         pPLOC  p = head_PLOC;
1966
1967         while (p) {
1968             strcpy(file, p->dir);
1969             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1970             file[NAM$C_MAXRSS] = '\0';
1971             p = p->next;
1972
1973             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1974
1975             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1976              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1977                 vmspipe_file_status = 1;
1978                 return vmspipe_file;
1979             }
1980         }
1981         vmspipe_file_status = -1;   /* failed, use tempfiles */
1982     }
1983
1984     return 0;
1985 }
1986
1987 static FILE *
1988 vmspipe_tempfile(pTHX)
1989 {
1990     char file[NAM$C_MAXRSS+1];
1991     FILE *fp;
1992     static int index = 0;
1993     stat_t s0, s1;
1994
1995     /* create a tempfile */
1996
1997     /* we can't go from   W, shr=get to  R, shr=get without
1998        an intermediate vulnerable state, so don't bother trying...
1999
2000        and lib$spawn doesn't shr=put, so have to close the write
2001
2002        So... match up the creation date/time and the FID to
2003        make sure we're dealing with the same file
2004
2005     */
2006
2007     index++;
2008     sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2009     fp = fopen(file,"w");
2010     if (!fp) {
2011         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2012         fp = fopen(file,"w");
2013         if (!fp) {
2014             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2015             fp = fopen(file,"w");
2016         }
2017     }
2018     if (!fp) return 0;  /* we're hosed */
2019
2020     fprintf(fp,"$! 'f$verify(0)\n");
2021     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
2022     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
2023     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2024     fprintf(fp,"$ perl_on     = \"set noon\"\n");
2025     fprintf(fp,"$ perl_exit   = \"exit\"\n");
2026     fprintf(fp,"$ perl_del    = \"delete\"\n");
2027     fprintf(fp,"$ pif         = \"if\"\n");
2028     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
2029     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
2030     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
2031     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
2032     fprintf(fp,"$ cmd = perl_popen_cmd\n");
2033     fprintf(fp,"$!  --- get rid of global symbols\n");
2034     fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
2035     fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
2036     fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
2037     fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
2038     fprintf(fp,"$ perl_on\n");
2039     fprintf(fp,"$ 'cmd\n");
2040     fprintf(fp,"$ perl_status = $STATUS\n");
2041     fprintf(fp,"$ perl_del  'perl_cfile'\n");
2042     fprintf(fp,"$ perl_exit 'perl_status'\n");
2043     fsync(fileno(fp));
2044
2045     fgetname(fp, file, 1);
2046     fstat(fileno(fp), &s0);
2047     fclose(fp);
2048
2049     fp = fopen(file,"r","shr=get");
2050     if (!fp) return 0;
2051     fstat(fileno(fp), &s1);
2052
2053     if (s0.st_ino[0] != s1.st_ino[0] ||
2054         s0.st_ino[1] != s1.st_ino[1] ||
2055         s0.st_ino[2] != s1.st_ino[2] ||
2056         s0.st_ctime  != s1.st_ctime  )  {
2057         fclose(fp);
2058         return 0;
2059     }
2060
2061     return fp;
2062 }
2063
2064
2065
2066 static PerlIO *
2067 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2068 {
2069     static int handler_set_up = FALSE;
2070     unsigned long int sts, flags=1;  /* nowait - gnu c doesn't allow &1 */
2071     unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2072     int wait = 0;
2073     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2074     char in[512], out[512], err[512], mbx[512];
2075     FILE *tpipe = 0;
2076     char tfilebuf[NAM$C_MAXRSS+1];
2077     pInfo info;
2078     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2079                                       DSC$K_CLASS_S, symbol};
2080     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2081                                       DSC$K_CLASS_S, 0};
2082
2083     $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
2084     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2085     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2086     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2087
2088     /* once-per-program initialization...
2089        note that the SETAST calls and the dual test of pipe_ef
2090        makes sure that only the FIRST thread through here does
2091        the initialization...all other threads wait until it's
2092        done.
2093
2094        Yeah, uglier than a pthread call, it's got all the stuff inline
2095        rather than in a separate routine.
2096     */
2097
2098     if (!pipe_ef) {
2099         _ckvmssts(sys$setast(0));
2100         if (!pipe_ef) {
2101             unsigned long int pidcode = JPI$_PID;
2102             $DESCRIPTOR(d_delay, RETRY_DELAY);
2103             _ckvmssts(lib$get_ef(&pipe_ef));
2104             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2105             _ckvmssts(sys$bintim(&d_delay, delaytime));
2106         }
2107         if (!handler_set_up) {
2108           _ckvmssts(sys$dclexh(&pipe_exitblock));
2109           handler_set_up = TRUE;
2110         }
2111         _ckvmssts(sys$setast(1));
2112     }
2113
2114     /* see if we can find a VMSPIPE.COM */
2115
2116     tfilebuf[0] = '@';
2117     vmspipe = find_vmspipe(aTHX);
2118     if (vmspipe) {
2119         strcpy(tfilebuf+1,vmspipe);
2120     } else {        /* uh, oh...we're in tempfile hell */
2121         tpipe = vmspipe_tempfile(aTHX);
2122         if (!tpipe) {       /* a fish popular in Boston */
2123             if (ckWARN(WARN_PIPE)) {
2124                 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2125             }
2126         return Nullfp;
2127         }
2128         fgetname(tpipe,tfilebuf+1,1);
2129     }
2130     vmspipedsc.dsc$a_pointer = tfilebuf;
2131     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
2132
2133     sts = setup_cmddsc(aTHX_ cmd,0,0);
2134     if (!(sts & 1)) {
2135       switch (sts) {
2136         case RMS$_FNF:  case RMS$_DNF:
2137           set_errno(ENOENT); break;
2138         case RMS$_DIR:
2139           set_errno(ENOTDIR); break;
2140         case RMS$_DEV:
2141           set_errno(ENODEV); break;
2142         case RMS$_PRV:
2143           set_errno(EACCES); break;
2144         case RMS$_SYN:
2145           set_errno(EINVAL); break;
2146         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2147           set_errno(E2BIG); break;
2148         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2149           _ckvmssts(sts); /* fall through */
2150         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2151           set_errno(EVMSERR);
2152       }
2153       set_vaxc_errno(sts);
2154       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2155         Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2156       }
2157       *psts = sts;
2158       return Nullfp;
2159     }
2160     New(1301,info,1,Info);
2161
2162     strcpy(mode,in_mode);
2163     info->mode = *mode;
2164     info->done = FALSE;
2165     info->completion = 0;
2166     info->closing    = FALSE;
2167     info->in         = 0;
2168     info->out        = 0;
2169     info->err        = 0;
2170     info->fp         = Nullfp;
2171     info->useFILE    = 0;
2172     info->waiting    = 0;
2173     info->in_done    = TRUE;
2174     info->out_done   = TRUE;
2175     info->err_done   = TRUE;
2176     in[0] = out[0] = err[0] = '\0';
2177
2178     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
2179         info->useFILE = 1;
2180         strcpy(p,p+1);
2181     }
2182     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
2183         wait = 1;
2184         strcpy(p,p+1);
2185     }
2186
2187     if (*mode == 'r') {             /* piping from subroutine */
2188
2189         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2190         if (info->out) {
2191             info->out->pipe_done = &info->out_done;
2192             info->out_done = FALSE;
2193             info->out->info = info;
2194         }
2195         if (!info->useFILE) {
2196         info->fp  = PerlIO_open(mbx, mode);
2197         } else {
2198             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2199             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2200         }
2201
2202         if (!info->fp && info->out) {
2203             sys$cancel(info->out->chan_out);
2204
2205             while (!info->out_done) {
2206                 int done;
2207                 _ckvmssts(sys$setast(0));
2208                 done = info->out_done;
2209                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2210                 _ckvmssts(sys$setast(1));
2211                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2212             }
2213
2214             if (info->out->buf) Safefree(info->out->buf);
2215             Safefree(info->out);
2216             Safefree(info);
2217             *psts = RMS$_FNF;
2218             return Nullfp;
2219         }
2220
2221         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2222         if (info->err) {
2223             info->err->pipe_done = &info->err_done;
2224             info->err_done = FALSE;
2225             info->err->info = info;
2226         }
2227
2228     } else if (*mode == 'w') {      /* piping to subroutine */
2229
2230         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2231         if (info->out) {
2232             info->out->pipe_done = &info->out_done;
2233             info->out_done = FALSE;
2234             info->out->info = info;
2235         }
2236
2237         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2238         if (info->err) {
2239             info->err->pipe_done = &info->err_done;
2240             info->err_done = FALSE;
2241             info->err->info = info;
2242         }
2243
2244         info->in = pipe_tochild_setup(aTHX_ in,mbx);
2245         if (!info->useFILE) {
2246         info->fp  = PerlIO_open(mbx, mode);
2247         } else {
2248             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2249             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2250         }
2251
2252         if (info->in) {
2253             info->in->pipe_done = &info->in_done;
2254             info->in_done = FALSE;
2255             info->in->info = info;
2256         }
2257
2258         /* error cleanup */
2259         if (!info->fp && info->in) {
2260             info->done = TRUE;
2261             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2262                               0, 0, 0, 0, 0, 0, 0, 0));
2263
2264             while (!info->in_done) {
2265                 int done;
2266                 _ckvmssts(sys$setast(0));
2267                 done = info->in_done;
2268                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2269                 _ckvmssts(sys$setast(1));
2270                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2271             }
2272
2273             if (info->in->buf) Safefree(info->in->buf);
2274             Safefree(info->in);
2275             Safefree(info);
2276             *psts = RMS$_FNF;
2277             return Nullfp;
2278         }
2279
2280
2281     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
2282         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2283         if (info->out) {
2284             info->out->pipe_done = &info->out_done;
2285             info->out_done = FALSE;
2286             info->out->info = info;
2287         }
2288
2289         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2290         if (info->err) {
2291             info->err->pipe_done = &info->err_done;
2292             info->err_done = FALSE;
2293             info->err->info = info;
2294         }
2295     }
2296
2297     symbol[MAX_DCL_SYMBOL] = '\0';
2298
2299     strncpy(symbol, in, MAX_DCL_SYMBOL);
2300     d_symbol.dsc$w_length = strlen(symbol);
2301     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2302
2303     strncpy(symbol, err, MAX_DCL_SYMBOL);
2304     d_symbol.dsc$w_length = strlen(symbol);
2305     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2306
2307     strncpy(symbol, out, MAX_DCL_SYMBOL);
2308     d_symbol.dsc$w_length = strlen(symbol);
2309     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2310
2311     p = VMSCMD.dsc$a_pointer;
2312     while (*p && *p != '\n') p++;
2313     *p = '\0';                                  /* truncate on \n */
2314     p = VMSCMD.dsc$a_pointer;
2315     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
2316     if (*p == '$') p++;                         /* remove leading $ */
2317     while (*p == ' ' || *p == '\t') p++;
2318     strncpy(symbol, p, MAX_DCL_SYMBOL);
2319     d_symbol.dsc$w_length = strlen(symbol);
2320     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2321
2322     _ckvmssts(sys$setast(0));
2323     info->next=open_pipes;  /* prepend to list */
2324     open_pipes=info;
2325     _ckvmssts(sys$setast(1));
2326     _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2327                       0, &info->pid, &info->completion,
2328                       0, popen_completion_ast,info,0,0,0));
2329
2330     /* if we were using a tempfile, close it now */
2331
2332     if (tpipe) fclose(tpipe);
2333
2334     /* once the subprocess is spawned, it has copied the symbols and
2335        we can get rid of ours */
2336
2337     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2338     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
2339     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2340     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2341     vms_execfree(aTHX);
2342
2343     PL_forkprocess = info->pid;
2344     if (wait) {
2345          int done = 0;
2346          while (!done) {
2347              _ckvmssts(sys$setast(0));
2348              done = info->done;
2349              if (!done) _ckvmssts(sys$clref(pipe_ef));
2350              _ckvmssts(sys$setast(1));
2351              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2352          }
2353         *psts = info->completion;
2354         my_pclose(info->fp);
2355     } else {
2356         *psts = SS$_NORMAL;
2357     }
2358     return info->fp;
2359 }  /* end of safe_popen */
2360
2361
2362 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
2363 PerlIO *
2364 Perl_my_popen(pTHX_ char *cmd, char *mode)
2365 {
2366     int sts;
2367     TAINT_ENV();
2368     TAINT_PROPER("popen");
2369     PERL_FLUSHALL_FOR_CHILD;
2370     return safe_popen(aTHX_ cmd,mode,&sts);
2371 }
2372
2373 /*}}}*/
2374
2375 /*{{{  I32 my_pclose(PerlIO *fp)*/
2376 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2377 {
2378     pInfo info, last = NULL;
2379     unsigned long int retsts;
2380     int done, iss;
2381
2382     for (info = open_pipes; info != NULL; last = info, info = info->next)
2383         if (info->fp == fp) break;
2384
2385     if (info == NULL) {  /* no such pipe open */
2386       set_errno(ECHILD); /* quoth POSIX */
2387       set_vaxc_errno(SS$_NONEXPR);
2388       return -1;
2389     }
2390
2391     /* If we were writing to a subprocess, insure that someone reading from
2392      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
2393      * produce an EOF record in the mailbox.
2394      *
2395      *  well, at least sometimes it *does*, so we have to watch out for
2396      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
2397      */
2398      if (info->fp) {
2399         if (!info->useFILE)
2400      PerlIO_flush(info->fp);   /* first, flush data */
2401         else
2402             fflush((FILE *)info->fp);
2403     }
2404
2405     _ckvmssts(sys$setast(0));
2406      info->closing = TRUE;
2407      done = info->done && info->in_done && info->out_done && info->err_done;
2408      /* hanging on write to Perl's input? cancel it */
2409      if (info->mode == 'r' && info->out && !info->out_done) {
2410         if (info->out->chan_out) {
2411             _ckvmssts(sys$cancel(info->out->chan_out));
2412             if (!info->out->chan_in) {   /* EOF generation, need AST */
2413                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2414             }
2415         }
2416      }
2417      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
2418          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2419                            0, 0, 0, 0, 0, 0));
2420     _ckvmssts(sys$setast(1));
2421     if (info->fp) {
2422      if (!info->useFILE)
2423     PerlIO_close(info->fp);
2424      else
2425         fclose((FILE *)info->fp);
2426     }
2427      /*
2428         we have to wait until subprocess completes, but ALSO wait until all
2429         the i/o completes...otherwise we'll be freeing the "info" structure
2430         that the i/o ASTs could still be using...
2431      */
2432
2433      while (!done) {
2434          _ckvmssts(sys$setast(0));
2435          done = info->done && info->in_done && info->out_done && info->err_done;
2436          if (!done) _ckvmssts(sys$clref(pipe_ef));
2437          _ckvmssts(sys$setast(1));
2438          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2439      }
2440      retsts = info->completion;
2441
2442     /* remove from list of open pipes */
2443     _ckvmssts(sys$setast(0));
2444     if (last) last->next = info->next;
2445     else open_pipes = info->next;
2446     _ckvmssts(sys$setast(1));
2447
2448     /* free buffers and structures */
2449
2450     if (info->in) {
2451         if (info->in->buf) Safefree(info->in->buf);
2452         Safefree(info->in);
2453     }
2454     if (info->out) {
2455         if (info->out->buf) Safefree(info->out->buf);
2456         Safefree(info->out);
2457     }
2458     if (info->err) {
2459         if (info->err->buf) Safefree(info->err->buf);
2460         Safefree(info->err);
2461     }
2462     Safefree(info);
2463
2464     return retsts;
2465
2466 }  /* end of my_pclose() */
2467
2468 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2469   /* Roll our own prototype because we want this regardless of whether
2470    * _VMS_WAIT is defined.
2471    */
2472   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2473 #endif
2474 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2475    created with popen(); otherwise partially emulate waitpid() unless
2476    we have a suitable one from the CRTL that came with VMS 7.2 and later.
2477    Also check processes not considered by the CRTL waitpid().
2478  */
2479 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2480 Pid_t
2481 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2482 {
2483     pInfo info;
2484     int done;
2485     int sts;
2486
2487     if (statusp) *statusp = 0;
2488
2489     for (info = open_pipes; info != NULL; info = info->next)
2490         if (info->pid == pid) break;
2491
2492     if (info != NULL) {  /* we know about this child */
2493       while (!info->done) {
2494           _ckvmssts(sys$setast(0));
2495           done = info->done;
2496           if (!done) _ckvmssts(sys$clref(pipe_ef));
2497           _ckvmssts(sys$setast(1));
2498           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2499       }
2500
2501       if (statusp) *statusp = info->completion;
2502       return pid;
2503
2504     }
2505     else {  /* this child is not one of our own pipe children */
2506
2507 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2508
2509       /* waitpid() became available in the CRTL as of VMS 7.0, but only
2510        * in 7.2 did we get a version that fills in the VMS completion
2511        * status as Perl has always tried to do.
2512        */
2513
2514       sts = __vms_waitpid( pid, statusp, flags );
2515
2516       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2517          return sts;
2518
2519       /* If the real waitpid tells us the child does not exist, we
2520        * fall through here to implement waiting for a child that
2521        * was created by some means other than exec() (say, spawned
2522        * from DCL) or to wait for a process that is not a subprocess
2523        * of the current process.
2524        */
2525
2526 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2527
2528       $DESCRIPTOR(intdsc,"0 00:00:01");
2529       unsigned long int ownercode = JPI$_OWNER, ownerpid;
2530       unsigned long int pidcode = JPI$_PID, mypid;
2531       unsigned long int interval[2];
2532       int termination_mbu = 0;
2533       unsigned short qio_iosb[4];
2534       unsigned int jpi_iosb[2];
2535       struct itmlst_3 jpilist[3] = {
2536           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
2537           {sizeof(termination_mbu), JPI$_TMBU,  &termination_mbu, 0},
2538           {                      0,         0,                 0, 0}
2539       };
2540       char trmmbx[NAM$C_DVI+1];
2541       $DESCRIPTOR(trmmbxdsc,trmmbx);
2542       struct accdef trmmsg;
2543       unsigned short int mbxchan;
2544
2545       if (pid <= 0) {
2546         /* Sorry folks, we don't presently implement rooting around for
2547            the first child we can find, and we definitely don't want to
2548            pass a pid of -1 to $getjpi, where it is a wildcard operation.
2549          */
2550         set_errno(ENOTSUP);
2551         return -1;
2552       }
2553
2554       /* Get the owner of the child so I can warn if it's not mine, plus
2555        * get the termination mailbox.  If the process doesn't exist or I
2556        * don't have the privs to look at it, I can go home early.
2557        */
2558       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2559       if (sts & 1) sts = jpi_iosb[0];
2560       if (!(sts & 1)) {
2561         switch (sts) {
2562             case SS$_NONEXPR:
2563                 set_errno(ECHILD);
2564                 break;
2565             case SS$_NOPRIV:
2566                 set_errno(EACCES);
2567                 break;
2568             default:
2569                 _ckvmssts(sts);
2570         }
2571         set_vaxc_errno(sts);
2572         return -1;
2573       }
2574
2575       if (ckWARN(WARN_EXEC)) {
2576         /* remind folks they are asking for non-standard waitpid behavior */
2577         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2578         if (ownerpid != mypid)
2579           Perl_warner(aTHX_ WARN_EXEC,
2580                       "waitpid: process %x is not a child of process %x",
2581                       pid,mypid);
2582       }
2583
2584       /* It's possible to have a mailbox unit number but no actual mailbox; we
2585        * check for this by assigning a channel to it, which we need anyway.
2586        */
2587       if (termination_mbu != 0) {
2588           sprintf(trmmbx, "MBA%d:", termination_mbu);
2589           trmmbxdsc.dsc$w_length = strlen(trmmbx);
2590           sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
2591           if (sts == SS$_NOSUCHDEV) {
2592               termination_mbu = 0; /* set up to take "no mailbox" case */
2593               sts = SS$_NORMAL;
2594           }
2595           _ckvmssts(sts);
2596       }
2597       /* If the process doesn't have a termination mailbox, then simply check
2598        * on it once a second until it's not there anymore.
2599        */
2600       if (termination_mbu == 0) {
2601           _ckvmssts(sys$bintim(&intdsc,interval));
2602           while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2603             _ckvmssts(sys$schdwk(0,0,interval,0));
2604             _ckvmssts(sys$hiber());
2605           }
2606           if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2607       }
2608       else {
2609         /* If we do have a termination mailbox, post reads to it until we get a
2610          * termination message, discarding messages of the wrong type or for other
2611          * processes.  If there is a place to put the final status, then do so.
2612          */
2613           sts = SS$_NORMAL;
2614           while (sts & 1) {
2615               memset((void *) &trmmsg, 0, sizeof(trmmsg));
2616               sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
2617                              &trmmsg,ACC$K_TERMLEN,0,0,0,0);
2618               if (sts & 1) sts = qio_iosb[0];
2619
2620               if ( sts & 1
2621                    && trmmsg.acc$w_msgtyp == MSG$_DELPROC
2622                    && trmmsg.acc$l_pid == pid ) {
2623
2624                   if (statusp) *statusp = trmmsg.acc$l_finalsts;
2625                   sts = sys$dassgn(mbxchan);
2626                   break;
2627               }
2628           }
2629       } /* termination_mbu ? */
2630
2631       _ckvmssts(sts);
2632       return pid;
2633
2634     } /* else one of our own pipe children */
2635
2636 }  /* end of waitpid() */
2637 /*}}}*/
2638 /*}}}*/
2639 /*}}}*/
2640
2641 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2642 char *
2643 my_gconvert(double val, int ndig, int trail, char *buf)
2644 {
2645   static char __gcvtbuf[DBL_DIG+1];
2646   char *loc;
2647
2648   loc = buf ? buf : __gcvtbuf;
2649
2650 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
2651   if (val < 1) {
2652     sprintf(loc,"%.*g",ndig,val);
2653     return loc;
2654   }
2655 #endif
2656
2657   if (val) {
2658     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2659     return gcvt(val,ndig,loc);
2660   }
2661   else {
2662     loc[0] = '0'; loc[1] = '\0';
2663     return loc;
2664   }
2665
2666 }
2667 /*}}}*/
2668
2669
2670 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2671 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2672  * to expand file specification.  Allows for a single default file
2673  * specification and a simple mask of options.  If outbuf is non-NULL,
2674  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2675  * the resultant file specification is placed.  If outbuf is NULL, the
2676  * resultant file specification is placed into a static buffer.
2677  * The third argument, if non-NULL, is taken to be a default file
2678  * specification string.  The fourth argument is unused at present.
2679  * rmesexpand() returns the address of the resultant string if
2680  * successful, and NULL on error.
2681  */
2682 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2683
2684 static char *
2685 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2686 {
2687   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2688   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2689   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2690   struct FAB myfab = cc$rms_fab;
2691   struct NAM mynam = cc$rms_nam;
2692   STRLEN speclen;
2693   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2694
2695   if (!filespec || !*filespec) {
2696     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2697     return NULL;
2698   }
2699   if (!outbuf) {
2700     if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2701     else    outbuf = __rmsexpand_retbuf;
2702   }
2703   if ((isunix = (strchr(filespec,'/') != NULL))) {
2704     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2705     filespec = vmsfspec;
2706   }
2707
2708   myfab.fab$l_fna = filespec;
2709   myfab.fab$b_fns = strlen(filespec);
2710   myfab.fab$l_nam = &mynam;
2711
2712   if (defspec && *defspec) {
2713     if (strchr(defspec,'/') != NULL) {
2714       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2715       defspec = tmpfspec;
2716     }
2717     myfab.fab$l_dna = defspec;
2718     myfab.fab$b_dns = strlen(defspec);
2719   }
2720
2721   mynam.nam$l_esa = esa;
2722   mynam.nam$b_ess = sizeof esa;
2723   mynam.nam$l_rsa = outbuf;
2724   mynam.nam$b_rss = NAM$C_MAXRSS;
2725
2726   retsts = sys$parse(&myfab,0,0);
2727   if (!(retsts & 1)) {
2728     mynam.nam$b_nop |= NAM$M_SYNCHK;
2729     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2730       retsts = sys$parse(&myfab,0,0);
2731       if (retsts & 1) goto expanded;
2732     }
2733     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2734     (void) sys$parse(&myfab,0,0);  /* Free search context */
2735     if (out) Safefree(out);
2736     set_vaxc_errno(retsts);
2737     if      (retsts == RMS$_PRV) set_errno(EACCES);
2738     else if (retsts == RMS$_DEV) set_errno(ENODEV);
2739     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2740     else                         set_errno(EVMSERR);
2741     return NULL;
2742   }
2743   retsts = sys$search(&myfab,0,0);
2744   if (!(retsts & 1) && retsts != RMS$_FNF) {
2745     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2746     myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
2747     if (out) Safefree(out);
2748     set_vaxc_errno(retsts);
2749     if      (retsts == RMS$_PRV) set_errno(EACCES);
2750     else                         set_errno(EVMSERR);
2751     return NULL;
2752   }
2753
2754   /* If the input filespec contained any lowercase characters,
2755    * downcase the result for compatibility with Unix-minded code. */
2756   expanded:
2757   for (out = myfab.fab$l_fna; *out; out++)
2758     if (islower(*out)) { haslower = 1; break; }
2759   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2760   else                 { out = esa;    speclen = mynam.nam$b_esl; }
2761   /* Trim off null fields added by $PARSE
2762    * If type > 1 char, must have been specified in original or default spec
2763    * (not true for version; $SEARCH may have added version of existing file).
2764    */
2765   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2766   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2767              (mynam.nam$l_ver - mynam.nam$l_type == 1);
2768   if (trimver || trimtype) {
2769     if (defspec && *defspec) {
2770       char defesa[NAM$C_MAXRSS];
2771       struct FAB deffab = cc$rms_fab;
2772       struct NAM defnam = cc$rms_nam;
2773
2774       deffab.fab$l_nam = &defnam;
2775       deffab.fab$l_fna = defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
2776       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
2777       defnam.nam$b_nop = NAM$M_SYNCHK;
2778       if (sys$parse(&deffab,0,0) & 1) {
2779         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2780         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2781       }
2782     }
2783     if (trimver) speclen = mynam.nam$l_ver - out;
2784     if (trimtype) {
2785       /* If we didn't already trim version, copy down */
2786       if (speclen > mynam.nam$l_ver - out)
2787         memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2788                speclen - (mynam.nam$l_ver - out));
2789       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2790     }
2791   }
2792   /* If we just had a directory spec on input, $PARSE "helpfully"
2793    * adds an empty name and type for us */
2794   if (mynam.nam$l_name == mynam.nam$l_type &&
2795       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
2796       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2797     speclen = mynam.nam$l_name - out;
2798   out[speclen] = '\0';
2799   if (haslower) __mystrtolower(out);
2800
2801   /* Have we been working with an expanded, but not resultant, spec? */
2802   /* Also, convert back to Unix syntax if necessary. */
2803   if (!mynam.nam$b_rsl) {
2804     if (isunix) {
2805       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2806     }
2807     else strcpy(outbuf,esa);
2808   }
2809   else if (isunix) {
2810     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2811     strcpy(outbuf,tmpfspec);
2812   }
2813   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2814   mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2815   myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
2816   return outbuf;
2817 }
2818 /*}}}*/
2819 /* External entry points */
2820 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2821 { return do_rmsexpand(spec,buf,0,def,opt); }
2822 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2823 { return do_rmsexpand(spec,buf,1,def,opt); }
2824
2825
2826 /*
2827 ** The following routines are provided to make life easier when
2828 ** converting among VMS-style and Unix-style directory specifications.
2829 ** All will take input specifications in either VMS or Unix syntax. On
2830 ** failure, all return NULL.  If successful, the routines listed below
2831 ** return a pointer to a buffer containing the appropriately
2832 ** reformatted spec (and, therefore, subsequent calls to that routine
2833 ** will clobber the result), while the routines of the same names with
2834 ** a _ts suffix appended will return a pointer to a mallocd string
2835 ** containing the appropriately reformatted spec.
2836 ** In all cases, only explicit syntax is altered; no check is made that
2837 ** the resulting string is valid or that the directory in question
2838 ** actually exists.
2839 **
2840 **   fileify_dirspec() - convert a directory spec into the name of the
2841 **     directory file (i.e. what you can stat() to see if it's a dir).
2842 **     The style (VMS or Unix) of the result is the same as the style
2843 **     of the parameter passed in.
2844 **   pathify_dirspec() - convert a directory spec into a path (i.e.
2845 **     what you prepend to a filename to indicate what directory it's in).
2846 **     The style (VMS or Unix) of the result is the same as the style
2847 **     of the parameter passed in.
2848 **   tounixpath() - convert a directory spec into a Unix-style path.
2849 **   tovmspath() - convert a directory spec into a VMS-style path.
2850 **   tounixspec() - convert any file spec into a Unix-style file spec.
2851 **   tovmsspec() - convert any file spec into a VMS-style spec.
2852 **
2853 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
2854 ** Permission is given to distribute this code as part of the Perl
2855 ** standard distribution under the terms of the GNU General Public
2856 ** License or the Perl Artistic License.  Copies of each may be
2857 ** found in the Perl standard distribution.
2858  */
2859
2860 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2861 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2862 {
2863     static char __fileify_retbuf[NAM$C_MAXRSS+1];
2864     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2865     char *retspec, *cp1, *cp2, *lastdir;
2866     char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2867
2868     if (!dir || !*dir) {
2869       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2870     }
2871     dirlen = strlen(dir);
2872     while (dirlen && dir[dirlen-1] == '/') --dirlen;
2873     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2874       strcpy(trndir,"/sys$disk/000000");
2875       dir = trndir;
2876       dirlen = 16;
2877     }
2878     if (dirlen > NAM$C_MAXRSS) {
2879       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2880     }
2881     if (!strpbrk(dir+1,"/]>:")) {
2882       strcpy(trndir,*dir == '/' ? dir + 1: dir);
2883       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2884       dir = trndir;
2885       dirlen = strlen(dir);
2886     }
2887     else {
2888       strncpy(trndir,dir,dirlen);
2889       trndir[dirlen] = '\0';
2890       dir = trndir;
2891     }
2892     /* If we were handed a rooted logical name or spec, treat it like a
2893      * simple directory, so that
2894      *    $ Define myroot dev:[dir.]
2895      *    ... do_fileify_dirspec("myroot",buf,1) ...
2896      * does something useful.
2897      */
2898     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2899       dir[--dirlen] = '\0';
2900       dir[dirlen-1] = ']';
2901     }
2902     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
2903       dir[--dirlen] = '\0';
2904       dir[dirlen-1] = '>';
2905     }
2906
2907     if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2908       /* If we've got an explicit filename, we can just shuffle the string. */
2909       if (*(cp1+1)) hasfilename = 1;
2910       /* Similarly, we can just back up a level if we've got multiple levels
2911          of explicit directories in a VMS spec which ends with directories. */
2912       else {
2913         for (cp2 = cp1; cp2 > dir; cp2--) {
2914           if (*cp2 == '.') {
2915             *cp2 = *cp1; *cp1 = '\0';
2916             hasfilename = 1;
2917             break;
2918           }
2919           if (*cp2 == '[' || *cp2 == '<') break;
2920         }
2921       }
2922     }
2923
2924     if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2925       if (dir[0] == '.') {
2926         if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2927           return do_fileify_dirspec("[]",buf,ts);
2928         else if (dir[1] == '.' &&
2929                  (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2930           return do_fileify_dirspec("[-]",buf,ts);
2931       }
2932       if (dirlen && dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
2933         dirlen -= 1;                 /* to last element */
2934         lastdir = strrchr(dir,'/');
2935       }
2936       else if ((cp1 = strstr(dir,"/.")) != NULL) {
2937         /* If we have "/." or "/..", VMSify it and let the VMS code
2938          * below expand it, rather than repeating the code to handle
2939          * relative components of a filespec here */
2940         do {
2941           if (*(cp1+2) == '.') cp1++;
2942           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2943             if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2944             if (strchr(vmsdir,'/') != NULL) {
2945               /* If do_tovmsspec() returned it, it must have VMS syntax
2946                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
2947                * the time to check this here only so we avoid a recursion
2948                * loop; otherwise, gigo.
2949                */
2950               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
2951             }
2952             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2953             return do_tounixspec(trndir,buf,ts);
2954           }
2955           cp1++;
2956         } while ((cp1 = strstr(cp1,"/.")) != NULL);
2957         lastdir = strrchr(dir,'/');
2958       }
2959       else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2960         /* Ditto for specs that end in an MFD -- let the VMS code
2961          * figure out whether it's a real device or a rooted logical. */
2962         dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2963         if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2964         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2965         return do_tounixspec(trndir,buf,ts);
2966       }
2967       else {
2968         if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2969              !(lastdir = cp1 = strrchr(dir,']')) &&
2970              !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2971         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
2972           int ver; char *cp3;
2973           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
2974               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
2975               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2976               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
2977               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2978                             (ver || *cp3)))))) {
2979             set_errno(ENOTDIR);
2980             set_vaxc_errno(RMS$_DIR);
2981             return NULL;
2982           }
2983           dirlen = cp2 - dir;
2984         }
2985       }
2986       /* If we lead off with a device or rooted logical, add the MFD
2987          if we're specifying a top-level directory. */
2988       if (lastdir && *dir == '/') {
2989         addmfd = 1;
2990         for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2991           if (*cp1 == '/') {
2992             addmfd = 0;
2993             break;
2994           }
2995         }
2996       }
2997       retlen = dirlen + (addmfd ? 13 : 6);
2998       if (buf) retspec = buf;
2999       else if (ts) New(1309,retspec,retlen+1,char);
3000       else retspec = __fileify_retbuf;
3001       if (addmfd) {
3002         dirlen = lastdir - dir;
3003         memcpy(retspec,dir,dirlen);
3004         strcpy(&retspec[dirlen],"/000000");
3005         strcpy(&retspec[dirlen+7],lastdir);
3006       }
3007       else {
3008         memcpy(retspec,dir,dirlen);
3009         retspec[dirlen] = '\0';
3010       }
3011       /* We've picked up everything up to the directory file name.
3012          Now just add the type and version, and we're set. */
3013       strcat(retspec,".dir;1");
3014       return retspec;
3015     }
3016     else {  /* VMS-style directory spec */
3017       char esa[NAM$C_MAXRSS+1], term, *cp;
3018       unsigned long int sts, cmplen, haslower = 0;
3019       struct FAB dirfab = cc$rms_fab;
3020       struct NAM savnam, dirnam = cc$rms_nam;
3021
3022       dirfab.fab$b_fns = strlen(dir);
3023       dirfab.fab$l_fna = dir;
3024       dirfab.fab$l_nam = &dirnam;
3025       dirfab.fab$l_dna = ".DIR;1";
3026       dirfab.fab$b_dns = 6;
3027       dirnam.nam$b_ess = NAM$C_MAXRSS;
3028       dirnam.nam$l_esa = esa;
3029
3030       for (cp = dir; *cp; cp++)
3031         if (islower(*cp)) { haslower = 1; break; }
3032       if (!((sts = sys$parse(&dirfab))&1)) {
3033         if (dirfab.fab$l_sts == RMS$_DIR) {
3034           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3035           sts = sys$parse(&dirfab) & 1;
3036         }
3037         if (!sts) {
3038           set_errno(EVMSERR);
3039           set_vaxc_errno(dirfab.fab$l_sts);
3040           return NULL;
3041         }
3042       }
3043       else {
3044         savnam = dirnam;
3045         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
3046           /* Yes; fake the fnb bits so we'll check type below */
3047           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3048         }
3049         else { /* No; just work with potential name */
3050           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3051           else {
3052             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
3053             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3054             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3055             return NULL;
3056           }
3057         }
3058       }
3059       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3060         cp1 = strchr(esa,']');
3061         if (!cp1) cp1 = strchr(esa,'>');
3062         if (cp1) {  /* Should always be true */
3063           dirnam.nam$b_esl -= cp1 - esa - 1;
3064           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3065         }
3066       }
3067       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3068         /* Yep; check version while we're at it, if it's there. */
3069         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3070         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3071           /* Something other than .DIR[;1].  Bzzt. */
3072           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3073           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3074           set_errno(ENOTDIR);
3075           set_vaxc_errno(RMS$_DIR);
3076           return NULL;
3077         }
3078       }
3079       esa[dirnam.nam$b_esl] = '\0';
3080       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3081         /* They provided at least the name; we added the type, if necessary, */
3082         if (buf) retspec = buf;                            /* in sys$parse() */
3083         else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3084         else retspec = __fileify_retbuf;
3085         strcpy(retspec,esa);
3086         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3087         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3088         return retspec;
3089       }
3090       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3091         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3092         *cp1 = '\0';
3093         dirnam.nam$b_esl -= 9;
3094       }
3095       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3096       if (cp1 == NULL) { /* should never happen */
3097         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3098         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3099         return NULL;
3100       }
3101       term = *cp1;
3102       *cp1 = '\0';
3103       retlen = strlen(esa);
3104       if ((cp1 = strrchr(esa,'.')) != NULL) {
3105         /* There's more than one directory in the path.  Just roll back. */
3106         *cp1 = term;
3107         if (buf) retspec = buf;
3108         else if (ts) New(1311,retspec,retlen+7,char);
3109         else retspec = __fileify_retbuf;
3110         strcpy(retspec,esa);
3111       }
3112       else {
3113         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3114           /* Go back and expand rooted logical name */
3115           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3116           if (!(sys$parse(&dirfab) & 1)) {
3117             dirnam.nam$l_rlf = NULL;
3118             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3119             set_errno(EVMSERR);
3120             set_vaxc_errno(dirfab.fab$l_sts);
3121             return NULL;
3122           }
3123           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3124           if (buf) retspec = buf;
3125           else if (ts) New(1312,retspec,retlen+16,char);
3126           else retspec = __fileify_retbuf;
3127           cp1 = strstr(esa,"][");
3128           if (!cp1) cp1 = strstr(esa,"]<");
3129           dirlen = cp1 - esa;
3130           memcpy(retspec,esa,dirlen);
3131           if (!strncmp(cp1+2,"000000]",7)) {
3132             retspec[dirlen-1] = '\0';
3133             for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3134             if (*cp1 == '.') *cp1 = ']';
3135             else {
3136               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3137               memcpy(cp1+1,"000000]",7);
3138             }
3139           }
3140           else {
3141             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3142             retspec[retlen] = '\0';
3143             /* Convert last '.' to ']' */
3144             for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3145             if (*cp1 == '.') *cp1 = ']';
3146             else {
3147               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3148               memcpy(cp1+1,"000000]",7);
3149             }
3150           }
3151         }
3152         else {  /* This is a top-level dir.  Add the MFD to the path. */
3153           if (buf) retspec = buf;
3154           else if (ts) New(1312,retspec,retlen+16,char);
3155           else retspec = __fileify_retbuf;
3156           cp1 = esa;
3157           cp2 = retspec;
3158           while (*cp1 != ':') *(cp2++) = *(cp1++);
3159           strcpy(cp2,":[000000]");
3160           cp1 += 2;
3161           strcpy(cp2+9,cp1);
3162         }
3163       }
3164       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3165       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3166       /* We've set up the string up through the filename.  Add the
3167          type and version, and we're done. */
3168       strcat(retspec,".DIR;1");
3169
3170       /* $PARSE may have upcased filespec, so convert output to lower
3171        * case if input contained any lowercase characters. */
3172       if (haslower) __mystrtolower(retspec);
3173       return retspec;
3174     }
3175 }  /* end of do_fileify_dirspec() */
3176 /*}}}*/
3177 /* External entry points */
3178 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3179 { return do_fileify_dirspec(dir,buf,0); }
3180 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3181 { return do_fileify_dirspec(dir,buf,1); }
3182
3183 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3184 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3185 {
3186     static char __pathify_retbuf[NAM$C_MAXRSS+1];
3187     unsigned long int retlen;
3188     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3189
3190     if (!dir || !*dir) {
3191       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3192     }
3193
3194     if (*dir) strcpy(trndir,dir);
3195     else getcwd(trndir,sizeof trndir - 1);
3196
3197     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3198            && my_trnlnm(trndir,trndir,0)) {
3199       STRLEN trnlen = strlen(trndir);
3200
3201       /* Trap simple rooted lnms, and return lnm:[000000] */
3202       if (!strcmp(trndir+trnlen-2,".]")) {
3203         if (buf) retpath = buf;
3204         else if (ts) New(1318,retpath,strlen(dir)+10,char);
3205         else retpath = __pathify_retbuf;
3206         strcpy(retpath,dir);
3207         strcat(retpath,":[000000]");
3208         return retpath;
3209       }
3210     }
3211     dir = trndir;
3212
3213     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3214       if (*dir == '.' && (*(dir+1) == '\0' ||
3215                           (*(dir+1) == '.' && *(dir+2) == '\0')))
3216         retlen = 2 + (*(dir+1) != '\0');
3217       else {
3218         if ( !(cp1 = strrchr(dir,'/')) &&
3219              !(cp1 = strrchr(dir,']')) &&
3220              !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3221         if ((cp2 = strchr(cp1,'.')) != NULL &&
3222             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
3223              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
3224               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3225               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3226           int ver; char *cp3;
3227           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3228               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3229               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3230               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3231               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3232                             (ver || *cp3)))))) {
3233             set_errno(ENOTDIR);
3234             set_vaxc_errno(RMS$_DIR);
3235             return NULL;
3236           }
3237           retlen = cp2 - dir + 1;
3238         }
3239         else {  /* No file type present.  Treat the filename as a directory. */
3240           retlen = strlen(dir) + 1;
3241         }
3242       }
3243       if (buf) retpath = buf;
3244       else if (ts) New(1313,retpath,retlen+1,char);
3245       else retpath = __pathify_retbuf;
3246       strncpy(retpath,dir,retlen-1);
3247       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3248         retpath[retlen-1] = '/';      /* with '/', add it. */
3249         retpath[retlen] = '\0';
3250       }
3251       else retpath[retlen-1] = '\0';
3252     }
3253     else {  /* VMS-style directory spec */
3254       char esa[NAM$C_MAXRSS+1], *cp;
3255       unsigned long int sts, cmplen, haslower;
3256       struct FAB dirfab = cc$rms_fab;
3257       struct NAM savnam, dirnam = cc$rms_nam;
3258
3259       /* If we've got an explicit filename, we can just shuffle the string. */
3260       if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3261              (cp1 = strrchr(dir,'>')) != NULL     ) && *(cp1+1)) {
3262         if ((cp2 = strchr(cp1,'.')) != NULL) {
3263           int ver; char *cp3;
3264           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3265               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3266               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3267               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3268               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3269                             (ver || *cp3)))))) {
3270             set_errno(ENOTDIR);
3271             set_vaxc_errno(RMS$_DIR);
3272             return NULL;
3273           }
3274         }
3275         else {  /* No file type, so just draw name into directory part */
3276           for (cp2 = cp1; *cp2; cp2++) ;
3277         }
3278         *cp2 = *cp1;
3279         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
3280         *cp1 = '.';
3281         /* We've now got a VMS 'path'; fall through */
3282       }
3283       dirfab.fab$b_fns = strlen(dir);
3284       dirfab.fab$l_fna = dir;
3285       if (dir[dirfab.fab$b_fns-1] == ']' ||
3286           dir[dirfab.fab$b_fns-1] == '>' ||
3287           dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3288         if (buf) retpath = buf;
3289         else if (ts) New(1314,retpath,strlen(dir)+1,char);
3290         else retpath = __pathify_retbuf;
3291         strcpy(retpath,dir);
3292         return retpath;
3293       }
3294       dirfab.fab$l_dna = ".DIR;1";
3295       dirfab.fab$b_dns = 6;
3296       dirfab.fab$l_nam = &dirnam;
3297       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3298       dirnam.nam$l_esa = esa;
3299
3300       for (cp = dir; *cp; cp++)
3301         if (islower(*cp)) { haslower = 1; break; }
3302
3303       if (!(sts = (sys$parse(&dirfab)&1))) {
3304         if (dirfab.fab$l_sts == RMS$_DIR) {
3305           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3306           sts = sys$parse(&dirfab) & 1;
3307         }
3308         if (!sts) {
3309           set_errno(EVMSERR);
3310           set_vaxc_errno(dirfab.fab$l_sts);
3311           return NULL;
3312         }
3313       }
3314       else {
3315         savnam = dirnam;
3316         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
3317           if (dirfab.fab$l_sts != RMS$_FNF) {
3318             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3319             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3320             set_errno(EVMSERR);
3321             set_vaxc_errno(dirfab.fab$l_sts);
3322             return NULL;
3323           }
3324           dirnam = savnam; /* No; just work with potential name */
3325         }
3326       }
3327       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3328         /* Yep; check version while we're at it, if it's there. */
3329         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3330         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3331           /* Something other than .DIR[;1].  Bzzt. */
3332           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3333           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3334           set_errno(ENOTDIR);
3335           set_vaxc_errno(RMS$_DIR);
3336           return NULL;
3337         }
3338       }
3339       /* OK, the type was fine.  Now pull any file name into the
3340          directory path. */
3341       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3342       else {
3343         cp1 = strrchr(esa,'>');
3344         *dirnam.nam$l_type = '>';
3345       }
3346       *cp1 = '.';
3347       *(dirnam.nam$l_type + 1) = '\0';
3348       retlen = dirnam.nam$l_type - esa + 2;
3349       if (buf) retpath = buf;
3350       else if (ts) New(1314,retpath,retlen,char);
3351       else retpath = __pathify_retbuf;
3352       strcpy(retpath,esa);
3353       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3354       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3355       /* $PARSE may have upcased filespec, so convert output to lower
3356        * case if input contained any lowercase characters. */
3357       if (haslower) __mystrtolower(retpath);
3358     }
3359
3360     return retpath;
3361 }  /* end of do_pathify_dirspec() */
3362 /*}}}*/
3363 /* External entry points */
3364 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3365 { return do_pathify_dirspec(dir,buf,0); }
3366 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3367 { return do_pathify_dirspec(dir,buf,1); }
3368
3369 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3370 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3371 {
3372   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3373   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3374   int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3375
3376   if (spec == NULL) return NULL;
3377   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3378   if (buf) rslt = buf;
3379   else if (ts) {
3380     retlen = strlen(spec);
3381     cp1 = strchr(spec,'[');
3382     if (!cp1) cp1 = strchr(spec,'<');
3383     if (cp1) {
3384       for (cp1++; *cp1; cp1++) {
3385         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
3386         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3387           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3388       }
3389     }
3390     New(1315,rslt,retlen+2+2*expand,char);
3391   }
3392   else rslt = __tounixspec_retbuf;
3393   if (strchr(spec,'/') != NULL) {
3394     strcpy(rslt,spec);
3395     return rslt;
3396   }
3397
3398   cp1 = rslt;
3399   cp2 = spec;
3400   dirend = strrchr(spec,']');
3401   if (dirend == NULL) dirend = strrchr(spec,'>');
3402   if (dirend == NULL) dirend = strchr(spec,':');
3403   if (dirend == NULL) {
3404     strcpy(rslt,spec);
3405     return rslt;
3406   }
3407   if (*cp2 != '[' && *cp2 != '<') {
3408     *(cp1++) = '/';
3409   }
3410   else {  /* the VMS spec begins with directories */
3411     cp2++;
3412     if (*cp2 == ']' || *cp2 == '>') {
3413       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3414       return rslt;
3415     }
3416     else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3417       if (getcwd(tmp,sizeof tmp,1) == NULL) {
3418         if (ts) Safefree(rslt);
3419         return NULL;
3420       }
3421       do {
3422         cp3 = tmp;
3423         while (*cp3 != ':' && *cp3) cp3++;
3424         *(cp3++) = '\0';
3425         if (strchr(cp3,']') != NULL) break;
3426       } while (vmstrnenv(tmp,tmp,0,fildev,0));
3427       if (ts && !buf &&
3428           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3429         retlen = devlen + dirlen;
3430         Renew(rslt,retlen+1+2*expand,char);
3431         cp1 = rslt;
3432       }
3433       cp3 = tmp;
3434       *(cp1++) = '/';
3435       while (*cp3) {
3436         *(cp1++) = *(cp3++);
3437         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3438       }
3439       *(cp1++) = '/';
3440     }
3441     else if ( *cp2 == '.') {
3442       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3443         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3444         cp2 += 3;
3445       }
3446       else cp2++;
3447     }
3448   }
3449   for (; cp2 <= dirend; cp2++) {
3450     if (*cp2 == ':') {
3451       *(cp1++) = '/';
3452       if (*(cp2+1) == '[') cp2++;
3453     }
3454     else if (*cp2 == ']' || *cp2 == '>') {
3455       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3456     }
3457     else if (*cp2 == '.') {
3458       *(cp1++) = '/';
3459       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3460         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3461                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3462         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3463             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3464       }
3465       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3466         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3467         cp2 += 2;
3468       }
3469     }
3470     else if (*cp2 == '-') {
3471       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3472         while (*cp2 == '-') {
3473           cp2++;
3474           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3475         }
3476         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3477           if (ts) Safefree(rslt);                        /* filespecs like */
3478           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
3479           return NULL;
3480         }
3481       }
3482       else *(cp1++) = *cp2;
3483     }
3484     else *(cp1++) = *cp2;
3485   }
3486   while (*cp2) *(cp1++) = *(cp2++);
3487   *cp1 = '\0';
3488
3489   return rslt;
3490
3491 }  /* end of do_tounixspec() */
3492 /*}}}*/
3493 /* External entry points */
3494 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3495 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3496
3497 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3498 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3499   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3500   char *rslt, *dirend;
3501   register char *cp1, *cp2;
3502   unsigned long int infront = 0, hasdir = 1;
3503
3504   if (path == NULL) return NULL;
3505   if (buf) rslt = buf;
3506   else if (ts) New(1316,rslt,strlen(path)+9,char);
3507   else rslt = __tovmsspec_retbuf;
3508   if (strpbrk(path,"]:>") ||
3509       (dirend = strrchr(path,'/')) == NULL) {
3510     if (path[0] == '.') {
3511       if (path[1] == '\0') strcpy(rslt,"[]");
3512       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3513       else strcpy(rslt,path); /* probably garbage */
3514     }
3515     else strcpy(rslt,path);
3516     return rslt;
3517   }
3518   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
3519     if (!*(dirend+2)) dirend +=2;
3520     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3521     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3522   }
3523   cp1 = rslt;
3524   cp2 = path;
3525   if (*cp2 == '/') {
3526     char trndev[NAM$C_MAXRSS+1];
3527     int islnm, rooted;
3528     STRLEN trnend;
3529
3530     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
3531     if (!*(cp2+1)) {
3532       if (!buf & ts) Renew(rslt,18,char);
3533       strcpy(rslt,"sys$disk:[000000]");
3534       return rslt;
3535     }
3536     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3537     *cp1 = '\0';
3538     islnm =  my_trnlnm(rslt,trndev,0);
3539     trnend = islnm ? strlen(trndev) - 1 : 0;
3540     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3541     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3542     /* If the first element of the path is a logical name, determine
3543      * whether it has to be translated so we can add more directories. */
3544     if (!islnm || rooted) {
3545       *(cp1++) = ':';
3546       *(cp1++) = '[';
3547       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3548       else cp2++;
3549     }
3550     else {
3551       if (cp2 != dirend) {
3552         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3553         strcpy(rslt,trndev);
3554         cp1 = rslt + trnend;
3555         *(cp1++) = '.';
3556         cp2++;
3557       }
3558       else {
3559         *(cp1++) = ':';
3560         hasdir = 0;
3561       }
3562     }
3563   }
3564   else {
3565     *(cp1++) = '[';
3566     if (*cp2 == '.') {
3567       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3568         cp2 += 2;         /* skip over "./" - it's redundant */
3569         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
3570       }
3571       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3572         *(cp1++) = '-';                                 /* "../" --> "-" */
3573         cp2 += 3;
3574       }
3575       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3576                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3577         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3578         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3579         cp2 += 4;
3580       }
3581       if (cp2 > dirend) cp2 = dirend;
3582     }
3583     else *(cp1++) = '.';
3584   }
3585   for (; cp2 < dirend; cp2++) {
3586     if (*cp2 == '/') {
3587       if (*(cp2-1) == '/') continue;
3588       if (*(cp1-1) != '.') *(cp1++) = '.';
3589       infront = 0;
3590     }
3591     else if (!infront && *cp2 == '.') {
3592       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3593       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
3594       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3595         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3596         else if (*(cp1-2) == '[') *(cp1-1) = '-';
3597         else {  /* back up over previous directory name */
3598           cp1--;
3599           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3600           if (*(cp1-1) == '[') {
3601             memcpy(cp1,"000000.",7);
3602             cp1 += 7;
3603           }
3604         }
3605         cp2 += 2;
3606         if (cp2 == dirend) break;
3607       }
3608       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3609                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3610         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3611         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3612         if (!*(cp2+3)) {
3613           *(cp1++) = '.';  /* Simulate trailing '/' */
3614           cp2 += 2;  /* for loop will incr this to == dirend */
3615         }
3616         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
3617       }
3618       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
3619     }
3620     else {
3621       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
3622       if (*cp2 == '.')      *(cp1++) = '_';
3623       else                  *(cp1++) =  *cp2;
3624       infront = 1;
3625     }
3626   }
3627   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3628   if (hasdir) *(cp1++) = ']';
3629   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
3630   while (*cp2) *(cp1++) = *(cp2++);
3631   *cp1 = '\0';
3632
3633   return rslt;
3634
3635 }  /* end of do_tovmsspec() */
3636 /*}}}*/
3637 /* External entry points */
3638 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3639 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3640
3641 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3642 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3643   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3644   int vmslen;
3645   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3646
3647   if (path == NULL) return NULL;
3648   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3649   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3650   if (buf) return buf;
3651   else if (ts) {
3652     vmslen = strlen(vmsified);
3653     New(1317,cp,vmslen+1,char);
3654     memcpy(cp,vmsified,vmslen);
3655     cp[vmslen] = '\0';
3656     return cp;
3657   }
3658   else {
3659     strcpy(__tovmspath_retbuf,vmsified);
3660     return __tovmspath_retbuf;
3661   }
3662
3663 }  /* end of do_tovmspath() */
3664 /*}}}*/
3665 /* External entry points */
3666 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3667 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3668
3669
3670 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3671 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3672   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3673   int unixlen;
3674   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3675
3676   if (path == NULL) return NULL;
3677   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3678   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3679   if (buf) return buf;
3680   else if (ts) {
3681     unixlen = strlen(unixified);
3682     New(1317,cp,unixlen+1,char);
3683     memcpy(cp,unixified,unixlen);
3684     cp[unixlen] = '\0';
3685     return cp;
3686   }
3687   else {
3688     strcpy(__tounixpath_retbuf,unixified);
3689     return __tounixpath_retbuf;
3690   }
3691
3692 }  /* end of do_tounixpath() */
3693 /*}}}*/
3694 /* External entry points */
3695 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3696 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3697
3698 /*
3699  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
3700  *
3701  *****************************************************************************
3702  *                                                                           *
3703  *  Copyright (C) 1989-1994 by                                               *
3704  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
3705  *                                                                           *
3706  *  Permission is hereby  granted for the reproduction of this software,     *
3707  *  on condition that this copyright notice is included in the reproduction, *
3708  *  and that such reproduction is not for purposes of profit or material     *
3709  *  gain.                                                                    *
3710  *                                                                           *
3711  *  27-Aug-1994 Modified for inclusion in perl5                              *
3712  *              by Charles Bailey  bailey@newman.upenn.edu                   *
3713  *****************************************************************************
3714  */
3715
3716 /*
3717  * getredirection() is intended to aid in porting C programs
3718  * to VMS (Vax-11 C).  The native VMS environment does not support
3719  * '>' and '<' I/O redirection, or command line wild card expansion,
3720  * or a command line pipe mechanism using the '|' AND background
3721  * command execution '&'.  All of these capabilities are provided to any
3722  * C program which calls this procedure as the first thing in the
3723  * main program.
3724  * The piping mechanism will probably work with almost any 'filter' type
3725  * of program.  With suitable modification, it may useful for other
3726  * portability problems as well.
3727  *
3728  * Author:  Mark Pizzolato      mark@infocomm.com
3729  */
3730 struct list_item
3731     {
3732     struct list_item *next;
3733     char *value;
3734     };
3735
3736 static void add_item(struct list_item **head,
3737                      struct list_item **tail,
3738                      char *value,
3739                      int *count);
3740
3741 static void mp_expand_wild_cards(pTHX_ char *item,
3742                                 struct list_item **head,
3743                                 struct list_item **tail,
3744                                 int *count);
3745
3746 static int background_process(int argc, char **argv);
3747
3748 static void pipe_and_fork(pTHX_ char **cmargv);
3749
3750 /*{{{ void getredirection(int *ac, char ***av)*/
3751 static void
3752 mp_getredirection(pTHX_ int *ac, char ***av)
3753 /*
3754  * Process vms redirection arg's.  Exit if any error is seen.
3755  * If getredirection() processes an argument, it is erased
3756  * from the vector.  getredirection() returns a new argc and argv value.
3757  * In the event that a background command is requested (by a trailing "&"),
3758  * this routine creates a background subprocess, and simply exits the program.
3759  *
3760  * Warning: do not try to simplify the code for vms.  The code
3761  * presupposes that getredirection() is called before any data is
3762  * read from stdin or written to stdout.
3763  *
3764  * Normal usage is as follows:
3765  *
3766  *      main(argc, argv)
3767  *      int             argc;
3768  *      char            *argv[];
3769  *      {
3770  *              getredirection(&argc, &argv);
3771  *      }
3772  */
3773 {
3774     int                 argc = *ac;     /* Argument Count         */
3775     char                **argv = *av;   /* Argument Vector        */
3776     char                *ap;            /* Argument pointer       */
3777     int                 j;              /* argv[] index           */
3778     int                 item_count = 0; /* Count of Items in List */
3779     struct list_item    *list_head = 0; /* First Item in List       */
3780     struct list_item    *list_tail;     /* Last Item in List        */
3781     char                *in = NULL;     /* Input File Name          */
3782     char                *out = NULL;    /* Output File Name         */
3783     char                *outmode = "w"; /* Mode to Open Output File */
3784     char                *err = NULL;    /* Error File Name          */
3785     char                *errmode = "w"; /* Mode to Open Error File  */
3786     int                 cmargc = 0;     /* Piped Command Arg Count  */
3787     char                **cmargv = NULL;/* Piped Command Arg Vector */
3788
3789     /*
3790      * First handle the case where the last thing on the line ends with
3791      * a '&'.  This indicates the desire for the command to be run in a
3792      * subprocess, so we satisfy that desire.
3793      */
3794     ap = argv[argc-1];
3795     if (0 == strcmp("&", ap))
3796         exit(background_process(--argc, argv));
3797     if (*ap && '&' == ap[strlen(ap)-1])
3798         {
3799         ap[strlen(ap)-1] = '\0';
3800         exit(background_process(argc, argv));
3801         }
3802     /*
3803      * Now we handle the general redirection cases that involve '>', '>>',
3804      * '<', and pipes '|'.
3805      */
3806     for (j = 0; j < argc; ++j)
3807         {
3808         if (0 == strcmp("<", argv[j]))
3809             {
3810             if (j+1 >= argc)
3811                 {
3812                 fprintf(stderr,"No input file after < on command line");
3813                 exit(LIB$_WRONUMARG);
3814                 }
3815             in = argv[++j];
3816             continue;
3817             }
3818         if ('<' == *(ap = argv[j]))
3819             {
3820             in = 1 + ap;
3821             continue;
3822             }
3823         if (0 == strcmp(">", ap))
3824             {
3825             if (j+1 >= argc)
3826                 {
3827                 fprintf(stderr,"No output file after > on command line");
3828                 exit(LIB$_WRONUMARG);
3829                 }
3830             out = argv[++j];
3831             continue;
3832             }
3833         if ('>' == *ap)
3834             {
3835             if ('>' == ap[1])
3836                 {
3837                 outmode = "a";
3838                 if ('\0' == ap[2])
3839                     out = argv[++j];
3840                 else
3841                     out = 2 + ap;
3842                 }
3843             else
3844                 out = 1 + ap;
3845             if (j >= argc)
3846                 {
3847                 fprintf(stderr,"No output file after > or >> on command line");
3848                 exit(LIB$_WRONUMARG);
3849                 }
3850             continue;
3851             }
3852         if (('2' == *ap) && ('>' == ap[1]))
3853             {
3854             if ('>' == ap[2])
3855                 {
3856                 errmode = "a";
3857                 if ('\0' == ap[3])
3858                     err = argv[++j];
3859                 else
3860                     err = 3 + ap;
3861                 }
3862             else
3863                 if ('\0' == ap[2])
3864                     err = argv[++j];
3865                 else
3866                     err = 2 + ap;
3867             if (j >= argc)
3868                 {
3869                 fprintf(stderr,"No output file after 2> or 2>> on command line");
3870                 exit(LIB$_WRONUMARG);
3871                 }
3872             continue;
3873             }
3874         if (0 == strcmp("|", argv[j]))
3875             {
3876             if (j+1 >= argc)
3877                 {
3878                 fprintf(stderr,"No command into which to pipe on command line");
3879                 exit(LIB$_WRONUMARG);
3880                 }
3881             cmargc = argc-(j+1);
3882             cmargv = &argv[j+1];
3883             argc = j;
3884             continue;
3885             }
3886         if ('|' == *(ap = argv[j]))
3887             {
3888             ++argv[j];
3889             cmargc = argc-j;
3890             cmargv = &argv[j];
3891             argc = j;
3892             continue;
3893             }
3894         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3895         }
3896     /*
3897      * Allocate and fill in the new argument vector, Some Unix's terminate
3898      * the list with an extra null pointer.
3899      */
3900     New(1302, argv, item_count+1, char *);
3901     *av = argv;
3902     for (j = 0; j < item_count; ++j, list_head = list_head->next)
3903         argv[j] = list_head->value;
3904     *ac = item_count;
3905     if (cmargv != NULL)
3906         {
3907         if (out != NULL)
3908             {
3909             fprintf(stderr,"'|' and '>' may not both be specified on command line");
3910             exit(LIB$_INVARGORD);
3911             }
3912         pipe_and_fork(aTHX_ cmargv);
3913         }
3914
3915     /* Check for input from a pipe (mailbox) */
3916
3917     if (in == NULL && 1 == isapipe(0))
3918         {
3919         char mbxname[L_tmpnam];
3920         long int bufsize;
3921         long int dvi_item = DVI$_DEVBUFSIZ;
3922         $DESCRIPTOR(mbxnam, "");
3923         $DESCRIPTOR(mbxdevnam, "");
3924
3925         /* Input from a pipe, reopen it in binary mode to disable       */
3926         /* carriage control processing.                                 */
3927
3928         fgetname(stdin, mbxname);
3929         mbxnam.dsc$a_pointer = mbxname;
3930         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3931         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3932         mbxdevnam.dsc$a_pointer = mbxname;
3933         mbxdevnam.dsc$w_length = sizeof(mbxname);
3934         dvi_item = DVI$_DEVNAM;
3935         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3936         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3937         set_errno(0);
3938         set_vaxc_errno(1);
3939         freopen(mbxname, "rb", stdin);
3940         if (errno != 0)
3941             {
3942             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3943             exit(vaxc$errno);
3944             }
3945         }
3946     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3947         {
3948         fprintf(stderr,"Can't open input file %s as stdin",in);
3949         exit(vaxc$errno);
3950         }
3951     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3952         {
3953         fprintf(stderr,"Can't open output file %s as stdout",out);
3954         exit(vaxc$errno);
3955         }
3956         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
3957
3958     if (err != NULL) {
3959         if (strcmp(err,"&1") == 0) {
3960             dup2(fileno(stdout), fileno(stderr));
3961             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
3962         } else {
3963         FILE *tmperr;
3964         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3965             {
3966             fprintf(stderr,"Can't open error file %s as stderr",err);
3967             exit(vaxc$errno);
3968             }
3969             fclose(tmperr);
3970            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
3971                 {
3972                 exit(vaxc$errno);
3973                 }
3974             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
3975         }
3976         }
3977 #ifdef ARGPROC_DEBUG
3978     PerlIO_printf(Perl_debug_log, "Arglist:\n");
3979     for (j = 0; j < *ac;  ++j)
3980         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3981 #endif
3982    /* Clear errors we may have hit expanding wildcards, so they don't
3983       show up in Perl's $! later */
3984    set_errno(0); set_vaxc_errno(1);
3985 }  /* end of getredirection() */
3986 /*}}}*/
3987
3988 static void add_item(struct list_item **head,
3989                      struct list_item **tail,
3990                      char *value,
3991                      int *count)
3992 {
3993     if (*head == 0)
3994         {
3995         New(1303,*head,1,struct list_item);
3996         *tail = *head;
3997         }
3998     else {
3999         New(1304,(*tail)->next,1,struct list_item);
4000         *tail = (*tail)->next;
4001         }
4002     (*tail)->value = value;
4003     ++(*count);
4004 }
4005
4006 static void mp_expand_wild_cards(pTHX_ char *item,
4007                               struct list_item **head,
4008                               struct list_item **tail,
4009                               int *count)
4010 {
4011 int expcount = 0;
4012 unsigned long int context = 0;
4013 int isunix = 0;
4014 char *had_version;
4015 char *had_device;
4016 int had_directory;
4017 char *devdir,*cp;
4018 char vmsspec[NAM$C_MAXRSS+1];
4019 $DESCRIPTOR(filespec, "");
4020 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4021 $DESCRIPTOR(resultspec, "");
4022 unsigned long int zero = 0, sts;
4023
4024     for (cp = item; *cp; cp++) {
4025         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4026         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4027     }
4028     if (!*cp || isspace(*cp))
4029         {
4030         add_item(head, tail, item, count);
4031         return;
4032         }
4033     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4034     resultspec.dsc$b_class = DSC$K_CLASS_D;
4035     resultspec.dsc$a_pointer = NULL;
4036     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4037       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4038     if (!isunix || !filespec.dsc$a_pointer)
4039       filespec.dsc$a_pointer = item;
4040     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4041     /*
4042      * Only return version specs, if the caller specified a version
4043      */
4044     had_version = strchr(item, ';');
4045     /*
4046      * Only return device and directory specs, if the caller specifed either.
4047      */
4048     had_device = strchr(item, ':');
4049     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4050
4051     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4052                                   &defaultspec, 0, 0, &zero))))
4053         {
4054         char *string;
4055         char *c;
4056
4057         New(1305,string,resultspec.dsc$w_length+1,char);
4058         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4059         string[resultspec.dsc$w_length] = '\0';
4060         if (NULL == had_version)
4061             *((char *)strrchr(string, ';')) = '\0';
4062         if ((!had_directory) && (had_device == NULL))
4063             {
4064             if (NULL == (devdir = strrchr(string, ']')))
4065                 devdir = strrchr(string, '>');
4066             strcpy(string, devdir + 1);
4067             }
4068         /*
4069          * Be consistent with what the C RTL has already done to the rest of
4070          * the argv items and lowercase all of these names.
4071          */
4072         for (c = string; *c; ++c)
4073             if (isupper(*c))
4074                 *c = tolower(*c);
4075         if (isunix) trim_unixpath(string,item,1);
4076         add_item(head, tail, string, count);
4077         ++expcount;
4078         }
4079     if (sts != RMS$_NMF)
4080         {
4081         set_vaxc_errno(sts);
4082         switch (sts)
4083             {
4084             case RMS$_FNF: case RMS$_DNF:
4085                 set_errno(ENOENT); break;
4086             case RMS$_DIR:
4087                 set_errno(ENOTDIR); break;
4088             case RMS$_DEV:
4089                 set_errno(ENODEV); break;
4090             case RMS$_FNM: case RMS$_SYN:
4091                 set_errno(EINVAL); break;
4092             case RMS$_PRV:
4093                 set_errno(EACCES); break;
4094             default:
4095                 _ckvmssts_noperl(sts);
4096             }
4097         }
4098     if (expcount == 0)
4099         add_item(head, tail, item, count);
4100     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4101     _ckvmssts_noperl(lib$find_file_end(&context));
4102 }
4103
4104 static int child_st[2];/* Event Flag set when child process completes   */
4105
4106 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
4107
4108 static unsigned long int exit_handler(int *status)
4109 {
4110 short iosb[4];
4111
4112     if (0 == child_st[0])
4113         {
4114 #ifdef ARGPROC_DEBUG
4115         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4116 #endif
4117         fflush(stdout);     /* Have to flush pipe for binary data to    */
4118                             /* terminate properly -- <tp@mccall.com>    */
4119         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4120         sys$dassgn(child_chan);
4121         fclose(stdout);
4122         sys$synch(0, child_st);
4123         }
4124     return(1);
4125 }
4126
4127 static void sig_child(int chan)
4128 {
4129 #ifdef ARGPROC_DEBUG
4130     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4131 #endif
4132     if (child_st[0] == 0)
4133         child_st[0] = 1;
4134 }
4135
4136 static struct exit_control_block exit_block =
4137     {
4138     0,
4139     exit_handler,
4140     1,
4141     &exit_block.exit_status,
4142     0
4143     };
4144
4145 static void
4146 pipe_and_fork(pTHX_ char **cmargv)
4147 {
4148     PerlIO *fp;
4149     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4150     int sts, j, l, ismcr, quote, tquote = 0;
4151
4152     sts = setup_cmddsc(cmargv[0],0,&quote);
4153
4154     j = l = 0;
4155     p = subcmd;
4156     q = cmargv[0];
4157     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
4158               && toupper(*(q+2)) == 'R' && !*(q+3);
4159
4160     while (q && l < MAX_DCL_LINE_LENGTH) {
4161         if (!*q) {
4162             if (j > 0 && quote) {
4163                 *p++ = '"';
4164                 l++;
4165             }
4166             q = cmargv[++j];
4167             if (q) {
4168                 if (ismcr && j > 1) quote = 1;
4169                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
4170                 *p++ = ' ';
4171                 l++;
4172                 if (quote || tquote) {
4173                     *p++ = '"';
4174                     l++;
4175                 }
4176         }
4177         } else {
4178             if ((quote||tquote) && *q == '"') {
4179                 *p++ = '"';
4180                 l++;
4181         }
4182             *p++ = *q++;
4183             l++;
4184         }
4185     }
4186     *p = '\0';
4187
4188     store_pipelocs();                   /* gets redone later */
4189     fp = safe_popen(subcmd,"wbF",&sts);
4190     if (fp == Nullfp) {
4191         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4192         }
4193 }
4194
4195 static int background_process(int argc, char **argv)
4196 {
4197 char command[2048] = "$";
4198 $DESCRIPTOR(value, "");
4199 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4200 static $DESCRIPTOR(null, "NLA0:");
4201 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4202 char pidstring[80];
4203 $DESCRIPTOR(pidstr, "");
4204 int pid;
4205 unsigned long int flags = 17, one = 1, retsts;
4206
4207     strcat(command, argv[0]);
4208     while (--argc)
4209         {
4210         strcat(command, " \"");
4211         strcat(command, *(++argv));
4212         strcat(command, "\"");
4213         }
4214     value.dsc$a_pointer = command;
4215     value.dsc$w_length = strlen(value.dsc$a_pointer);
4216     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4217     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4218     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4219         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4220     }
4221     else {
4222         _ckvmssts_noperl(retsts);
4223     }
4224 #ifdef ARGPROC_DEBUG
4225     PerlIO_printf(Perl_debug_log, "%s\n", command);
4226 #endif
4227     sprintf(pidstring, "%08X", pid);
4228     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4229     pidstr.dsc$a_pointer = pidstring;
4230     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4231     lib$set_symbol(&pidsymbol, &pidstr);
4232     return(SS$_NORMAL);
4233 }
4234 /*}}}*/
4235 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4236
4237
4238 /* OS-specific initialization at image activation (not thread startup) */
4239 /* Older VAXC header files lack these constants */
4240 #ifndef JPI$_RIGHTS_SIZE
4241 #  define JPI$_RIGHTS_SIZE 817
4242 #endif
4243 #ifndef KGB$M_SUBSYSTEM
4244 #  define KGB$M_SUBSYSTEM 0x8
4245 #endif
4246
4247 /*{{{void vms_image_init(int *, char ***)*/
4248 void
4249 vms_image_init(int *argcp, char ***argvp)
4250 {
4251   char eqv[LNM$C_NAMLENGTH+1] = "";
4252   unsigned int len, tabct = 8, tabidx = 0;
4253   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4254   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4255   unsigned short int dummy, rlen;
4256   struct dsc$descriptor_s **tabvec;
4257 #if defined(PERL_IMPLICIT_CONTEXT)
4258   pTHX = NULL;
4259 #endif
4260   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
4261                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
4262                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4263                                  {          0,                0,    0,      0} };
4264
4265   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4266   _ckvmssts_noperl(iosb[0]);
4267   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4268     if (iprv[i]) {           /* Running image installed with privs? */
4269       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
4270       will_taint = TRUE;
4271       break;
4272     }
4273   }
4274   /* Rights identifiers might trigger tainting as well. */
4275   if (!will_taint && (rlen || rsz)) {
4276     while (rlen < rsz) {
4277       /* We didn't get all the identifiers on the first pass.  Allocate a
4278        * buffer much larger than $GETJPI wants (rsz is size in bytes that
4279        * were needed to hold all identifiers at time of last call; we'll
4280        * allocate that many unsigned long ints), and go back and get 'em.
4281        * If it gave us less than it wanted to despite ample buffer space,
4282        * something's broken.  Is your system missing a system identifier?
4283        */
4284       if (rsz <= jpilist[1].buflen) {
4285          /* Perl_croak accvios when used this early in startup. */
4286          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4287                          rsz, (unsigned long) jpilist[1].buflen,
4288                          "Check your rights database for corruption.\n");
4289          exit(SS$_ABORT);
4290       }
4291       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4292       jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4293       jpilist[1].buflen = rsz * sizeof(unsigned long int);
4294       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4295       _ckvmssts_noperl(iosb[0]);
4296     }
4297     mask = jpilist[1].bufadr;
4298     /* Check attribute flags for each identifier (2nd longword); protected
4299      * subsystem identifiers trigger tainting.
4300      */
4301     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4302       if (mask[i] & KGB$M_SUBSYSTEM) {
4303         will_taint = TRUE;
4304         break;
4305       }
4306     }
4307     if (mask != rlst) Safefree(mask);
4308   }
4309   /* We need to use this hack to tell Perl it should run with tainting,
4310    * since its tainting flag may be part of the PL_curinterp struct, which
4311    * hasn't been allocated when vms_image_init() is called.
4312    */
4313   if (will_taint) {
4314     char ***newap;
4315     New(1320,newap,*argcp+2,char **);
4316     newap[0] = argvp[0];
4317     *newap[1] = "-T";
4318     Copy(argvp[1],newap[2],*argcp-1,char **);
4319     /* We orphan the old argv, since we don't know where it's come from,
4320      * so we don't know how to free it.
4321      */
4322     *argcp++; argvp = newap;
4323   }
4324   else {  /* Did user explicitly request tainting? */
4325     int i;
4326     char *cp, **av = *argvp;
4327     for (i = 1; i < *argcp; i++) {
4328       if (*av[i] != '-') break;
4329       for (cp = av[i]+1; *cp; cp++) {
4330         if (*cp == 'T') { will_taint = 1; break; }
4331         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4332                   strchr("DFIiMmx",*cp)) break;
4333       }
4334       if (will_taint) break;
4335     }
4336   }
4337
4338   for (tabidx = 0;
4339        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4340        tabidx++) {
4341     if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4342     else if (tabidx >= tabct) {
4343       tabct += 8;
4344       Renew(tabvec,tabct,struct dsc$descriptor_s *);
4345     }
4346     New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4347     tabvec[tabidx]->dsc$w_length  = 0;
4348     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
4349     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
4350     tabvec[tabidx]->dsc$a_pointer = NULL;
4351     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4352   }
4353   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4354
4355   getredirection(argcp,argvp);
4356 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4357   {
4358 # include <reentrancy.h>
4359   (void) decc$set_reentrancy(C$C_MULTITHREAD);
4360   }
4361 #endif
4362   return;
4363 }
4364 /*}}}*/
4365
4366
4367 /* trim_unixpath()
4368  * Trim Unix-style prefix off filespec, so it looks like what a shell
4369  * glob expansion would return (i.e. from specified prefix on, not
4370  * full path).  Note that returned filespec is Unix-style, regardless
4371  * of whether input filespec was VMS-style or Unix-style.
4372  *
4373  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4374  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
4375  * vector of options; at present, only bit 0 is used, and if set tells
4376  * trim unixpath to try the current default directory as a prefix when
4377  * presented with a possibly ambiguous ... wildcard.
4378  *
4379  * Returns !=0 on success, with trimmed filespec replacing contents of
4380  * fspec, and 0 on failure, with contents of fpsec unchanged.
4381  */
4382 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4383 int
4384 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4385 {
4386   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4387        *template, *base, *end, *cp1, *cp2;
4388   register int tmplen, reslen = 0, dirs = 0;
4389
4390   if (!wildspec || !fspec) return 0;
4391   if (strpbrk(wildspec,"]>:") != NULL) {
4392     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4393     else template = unixwild;
4394   }
4395   else template = wildspec;
4396   if (strpbrk(fspec,"]>:") != NULL) {
4397     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4398     else base = unixified;
4399     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4400      * check to see that final result fits into (isn't longer than) fspec */
4401     reslen = strlen(fspec);
4402   }
4403   else base = fspec;
4404
4405   /* No prefix or absolute path on wildcard, so nothing to remove */
4406   if (!*template || *template == '/') {
4407     if (base == fspec) return 1;
4408     tmplen = strlen(unixified);
4409     if (tmplen > reslen) return 0;  /* not enough space */
4410     /* Copy unixified resultant, including trailing NUL */
4411     memmove(fspec,unixified,tmplen+1);
4412     return 1;
4413   }
4414
4415   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
4416   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4417     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4418     for (cp1 = end ;cp1 >= base; cp1--)
4419       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4420         { cp1++; break; }
4421     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4422     return 1;
4423   }
4424   else {
4425     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4426     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4427     int ells = 1, totells, segdirs, match;
4428     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4429                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4430
4431     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4432     totells = ells;
4433     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4434     if (ellipsis == template && opts & 1) {
4435       /* Template begins with an ellipsis.  Since we can't tell how many
4436        * directory names at the front of the resultant to keep for an
4437        * arbitrary starting point, we arbitrarily choose the current
4438        * default directory as a starting point.  If it's there as a prefix,
4439        * clip it off.  If not, fall through and act as if the leading
4440        * ellipsis weren't there (i.e. return shortest possible path that
4441        * could match template).
4442        */
4443       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4444       for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4445         if (_tolower(*cp1) != _tolower(*cp2)) break;
4446       segdirs = dirs - totells;  /* Min # of dirs we must have left */
4447       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4448       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4449         memcpy(fspec,cp2+1,end - cp2);
4450         return 1;
4451       }
4452     }
4453     /* First off, back up over constant elements at end of path */
4454     if (dirs) {
4455       for (front = end ; front >= base; front--)
4456          if (*front == '/' && !dirs--) { front++; break; }
4457     }
4458     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4459          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
4460     if (cp1 != '\0') return 0;  /* Path too long. */
4461     lcend = cp2;
4462     *cp2 = '\0';  /* Pick up with memcpy later */
4463     lcfront = lcres + (front - base);
4464     /* Now skip over each ellipsis and try to match the path in front of it. */
4465     while (ells--) {
4466       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4467         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
4468             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
4469       if (cp1 < template) break; /* template started with an ellipsis */
4470       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4471         ellipsis = cp1; continue;
4472       }
4473       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4474       nextell = cp1;
4475       for (segdirs = 0, cp2 = tpl;
4476            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4477            cp1++, cp2++) {
4478          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4479          else *cp2 = _tolower(*cp1);  /* else lowercase for match */
4480          if (*cp2 == '/') segdirs++;
4481       }
4482       if (cp1 != ellipsis - 1) return 0; /* Path too long */
4483       /* Back up at least as many dirs as in template before matching */
4484       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4485         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4486       for (match = 0; cp1 > lcres;) {
4487         resdsc.dsc$a_pointer = cp1;
4488         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4489           match++;
4490           if (match == 1) lcfront = cp1;
4491         }
4492         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4493       }
4494       if (!match) return 0;  /* Can't find prefix ??? */
4495       if (match > 1 && opts & 1) {
4496         /* This ... wildcard could cover more than one set of dirs (i.e.
4497          * a set of similar dir names is repeated).  If the template
4498          * contains more than 1 ..., upstream elements could resolve the
4499          * ambiguity, but it's not worth a full backtracking setup here.
4500          * As a quick heuristic, clip off the current default directory
4501          * if it's present to find the trimmed spec, else use the
4502          * shortest string that this ... could cover.
4503          */
4504         char def[NAM$C_MAXRSS+1], *st;
4505
4506         if (getcwd(def, sizeof def,0) == NULL) return 0;
4507         for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4508           if (_tolower(*cp1) != _tolower(*cp2)) break;
4509         segdirs = dirs - totells;  /* Min # of dirs we must have left */
4510         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4511         if (*cp1 == '\0' && *cp2 == '/') {
4512           memcpy(fspec,cp2+1,end - cp2);
4513           return 1;
4514         }
4515         /* Nope -- stick with lcfront from above and keep going. */
4516       }
4517     }
4518     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4519     return 1;
4520     ellipsis = nextell;
4521   }
4522
4523 }  /* end of trim_unixpath() */
4524 /*}}}*/
4525
4526
4527 /*
4528  *  VMS readdir() routines.
4529  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4530  *
4531  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
4532  *  Minor modifications to original routines.
4533  */
4534
4535     /* Number of elements in vms_versions array */
4536 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
4537
4538 /*
4539  *  Open a directory, return a handle for later use.
4540  */
4541 /*{{{ DIR *opendir(char*name) */
4542 DIR *
4543 Perl_opendir(pTHX_ char *name)
4544 {
4545     DIR *dd;
4546     char dir[NAM$C_MAXRSS+1];
4547     Stat_t sb;
4548
4549     if (do_tovmspath(name,dir,0) == NULL) {
4550       return NULL;
4551     }
4552     if (flex_stat(dir,&sb) == -1) return NULL;
4553     if (!S_ISDIR(sb.st_mode)) {
4554       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
4555       return NULL;
4556     }
4557     if (!cando_by_name(S_IRUSR,0,dir)) {
4558       set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4559       return NULL;
4560     }
4561     /* Get memory for the handle, and the pattern. */
4562     New(1306,dd,1,DIR);
4563     New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4564
4565     /* Fill in the fields; mainly playing with the descriptor. */
4566     (void)sprintf(dd->pattern, "%s*.*",dir);
4567     dd->context = 0;
4568     dd->count = 0;
4569     dd->vms_wantversions = 0;
4570     dd->pat.dsc$a_pointer = dd->pattern;
4571     dd->pat.dsc$w_length = strlen(dd->pattern);
4572     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4573     dd->pat.dsc$b_class = DSC$K_CLASS_S;
4574
4575     return dd;
4576 }  /* end of opendir() */
4577 /*}}}*/
4578
4579 /*
4580  *  Set the flag to indicate we want versions or not.
4581  */
4582 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4583 void
4584 vmsreaddirversions(DIR *dd, int flag)
4585 {
4586     dd->vms_wantversions = flag;
4587 }
4588 /*}}}*/
4589
4590 /*
4591  *  Free up an opened directory.
4592  */
4593 /*{{{ void closedir(DIR *dd)*/
4594 void
4595 closedir(DIR *dd)
4596 {
4597     (void)lib$find_file_end(&dd->context);
4598     Safefree(dd->pattern);
4599     Safefree((char *)dd);
4600 }
4601 /*}}}*/
4602
4603 /*
4604  *  Collect all the version numbers for the current file.
4605  */
4606 static void
4607 collectversions(pTHX_ DIR *dd)
4608 {
4609     struct dsc$descriptor_s     pat;
4610     struct dsc$descriptor_s     res;
4611     struct dirent *e;
4612     char *p, *text, buff[sizeof dd->entry.d_name];
4613     int i;
4614     unsigned long context, tmpsts;
4615
4616     /* Convenient shorthand. */
4617     e = &dd->entry;
4618
4619     /* Add the version wildcard, ignoring the "*.*" put on before */
4620     i = strlen(dd->pattern);
4621     New(1308,text,i + e->d_namlen + 3,char);
4622     (void)strcpy(text, dd->pattern);
4623     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4624
4625     /* Set up the pattern descriptor. */
4626     pat.dsc$a_pointer = text;
4627     pat.dsc$w_length = i + e->d_namlen - 1;
4628     pat.dsc$b_dtype = DSC$K_DTYPE_T;
4629     pat.dsc$b_class = DSC$K_CLASS_S;
4630
4631     /* Set up result descriptor. */
4632     res.dsc$a_pointer = buff;
4633     res.dsc$w_length = sizeof buff - 2;
4634     res.dsc$b_dtype = DSC$K_DTYPE_T;
4635     res.dsc$b_class = DSC$K_CLASS_S;
4636
4637     /* Read files, collecting versions. */
4638     for (context = 0, e->vms_verscount = 0;
4639          e->vms_verscount < VERSIZE(e);
4640          e->vms_verscount++) {
4641         tmpsts = lib$find_file(&pat, &res, &context);
4642         if (tmpsts == RMS$_NMF || context == 0) break;
4643         _ckvmssts(tmpsts);
4644         buff[sizeof buff - 1] = '\0';
4645         if ((p = strchr(buff, ';')))
4646             e->vms_versions[e->vms_verscount] = atoi(p + 1);
4647         else
4648             e->vms_versions[e->vms_verscount] = -1;
4649     }
4650
4651     _ckvmssts(lib$find_file_end(&context));
4652     Safefree(text);
4653
4654 }  /* end of collectversions() */
4655
4656 /*
4657  *  Read the next entry from the directory.
4658  */
4659 /*{{{ struct dirent *readdir(DIR *dd)*/
4660 struct dirent *
4661 Perl_readdir(pTHX_ DIR *dd)
4662 {
4663     struct dsc$descriptor_s     res;
4664     char *p, buff[sizeof dd->entry.d_name];
4665     unsigned long int tmpsts;
4666
4667     /* Set up result descriptor, and get next file. */
4668     res.dsc$a_pointer = buff;
4669     res.dsc$w_length = sizeof buff - 2;
4670     res.dsc$b_dtype = DSC$K_DTYPE_T;
4671     res.dsc$b_class = DSC$K_CLASS_S;
4672     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4673     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
4674     if (!(tmpsts & 1)) {
4675       set_vaxc_errno(tmpsts);
4676       switch (tmpsts) {
4677         case RMS$_PRV:
4678           set_errno(EACCES); break;
4679         case RMS$_DEV:
4680           set_errno(ENODEV); break;
4681         case RMS$_DIR:
4682           set_errno(ENOTDIR); break;
4683         case RMS$_FNF: case RMS$_DNF:
4684           set_errno(ENOENT); break;
4685         default:
4686           set_errno(EVMSERR);
4687       }
4688       return NULL;
4689     }
4690     dd->count++;
4691     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4692     buff[sizeof buff - 1] = '\0';