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 /* Temp for subprocess commands */
 131 static struct dsc$descriptor_s VMSCMD = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
 132
 133 #ifndef RTL_USES_UTC
 134 static int tz_updated = 1;
 135 #endif
 136
 137 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 138 int
 139 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 140   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 141 {
 142     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
 143     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 144     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 145     unsigned char acmode;
 146     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 147                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 148     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 149                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 150                                  {0, 0, 0, 0}};
 151     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 152 #if defined(PERL_IMPLICIT_CONTEXT)
 153     pTHX = NULL;
 154 #  if defined(USE_5005THREADS)
 155     /* We jump through these hoops because we can be called at */
 156     /* platform-specific initialization time, which is before anything is */
 157     /* set up--we can't even do a plain dTHX since that relies on the */
 158     /* interpreter structure to be initialized */
 159     if (PL_curinterp) {
 160       aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
 161     } else {
 162       aTHX = NULL;
 163     }
 164 # else
 165     if (PL_curinterp) {
 166       aTHX = PERL_GET_INTERP;
 167     } else {
 168       aTHX = NULL;
 169     }
 170
 171 #  endif
 172 #endif
 173
 174     if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
 175       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 176     }
 177     for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 178       *cp2 = _toupper(*cp1);
 179       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 180         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 181         return 0;
 182       }
 183     }
 184     lnmdsc.dsc$w_length = cp1 - lnm;
 185     lnmdsc.dsc$a_pointer = uplnm;
 186     uplnm[lnmdsc.dsc$w_length] = '\0';
 187     secure = flags & PERL__TRNENV_SECURE;
 188     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 189     if (!tabvec || !*tabvec) tabvec = env_tables;
 190
 191     for (curtab = 0; tabvec[curtab]; curtab++) {
 192       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 193         if (!ivenv && !secure) {
 194           char *eq, *end;
 195           int i;
 196           if (!environ) {
 197             ivenv = 1;
 198             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 199             continue;
 200           }
 201           retsts = SS$_NOLOGNAM;
 202           for (i = 0; environ[i]; i++) {
 203             if ((eq = strchr(environ[i],'=')) &&
 204                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 205               eq++;
 206               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 207               if (!eqvlen) continue;
 208               retsts = SS$_NORMAL;
 209               break;
 210             }
 211           }
 212           if (retsts != SS$_NOLOGNAM) break;
 213         }
 214       }
 215       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 216                !str$case_blind_compare(&tmpdsc,&clisym)) {
 217         if (!ivsym && !secure) {
 218           unsigned short int deflen = LNM$C_NAMLENGTH;
 219           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 220           /* dynamic dsc to accomodate possible long value */
 221           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 222           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 223           if (retsts & 1) {
 224             if (eqvlen > 1024) {
 225               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 226               eqvlen = 1024;
 227               /* Special hack--we might be called before the interpreter's */
 228               /* fully initialized, in which case either thr or PL_curcop */
 229               /* might be bogus. We have to check, since ckWARN needs them */
 230               /* both to be valid if running threaded */
 231 #if defined(USE_5005THREADS)
 232               if (thr && PL_curcop) {
 233 #endif
 234                 if (ckWARN(WARN_MISC)) {
 235                   Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
 236                 }
 237 #if defined(USE_5005THREADS)
 238               } else {
 239                   Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
 240               }
 241 #endif
 242
 243             }
 244             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 245           }
 246           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 247           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 248           if (retsts == LIB$_NOSUCHSYM) continue;
 249           break;
 250         }
 251       }
 252       else if (!ivlnm) {
 253         retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 254         if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 255         if (retsts == SS$_NOLOGNAM) continue;
 256         /* PPFs have a prefix */
 257         if (
 258 #if INTSIZE == 4
 259              *((int *)uplnm) == *((int *)"SYS$")                    &&
 260 #endif
 261              eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 262              ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 263                (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 264                (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 265                (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 266           memcpy(eqv,eqv+4,eqvlen-4);
 267           eqvlen -= 4;
 268         }
 269         break;
 270       }
 271     }
 272     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 273     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 274              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 275              retsts == SS$_NOLOGNAM) {
 276       set_errno(EINVAL);  set_vaxc_errno(retsts);
 277     }
 278     else _ckvmssts(retsts);
 279     return 0;
 280 }  /* end of vmstrnenv */
 281 /*}}}*/
 282
 283 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 284 /* Define as a function so we can access statics. */
 285 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 286 {
 287   return vmstrnenv(lnm,eqv,idx,fildev,
 288 #ifdef SECURE_INTERNAL_GETENV
 289                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 290 #else
 291                    0
 292 #endif
 293                                                                               );
 294 }
 295 /*}}}*/
 296
 297 /* my_getenv
 298  * Note: Uses Perl temp to store result so char * can be returned to
 299  * caller; this pointer will be invalidated at next Perl statement
 300  * transition.
 301  * We define this as a function rather than a macro in terms of my_getenv_len()
 302  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 303  * allocate SVs).
 304  */
 305 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 306 char *
 307 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 308 {
 309     static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
 310     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
 311     unsigned long int idx = 0;
 312     int trnsuccess, success, secure, saverr, savvmserr;
 313     SV *tmpsv;
 314
 315     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 316       /* Set up a temporary buffer for the return value; Perl will
 317        * clean it up at the next statement transition */
 318       tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
 319       if (!tmpsv) return NULL;
 320       eqv = SvPVX(tmpsv);
 321     }
 322     else eqv = __my_getenv_eqv;  /* Assume no interpreter ==> single thread */
 323     for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 324     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 325       getcwd(eqv,LNM$C_NAMLENGTH);
 326       return eqv;
 327     }
 328     else {
 329       if ((cp2 = strchr(lnm,';')) != NULL) {
 330         strcpy(uplnm,lnm);
 331         uplnm[cp2-lnm] = '\0';
 332         idx = strtoul(cp2+1,NULL,0);
 333         lnm = uplnm;
 334       }
 335       /* Impose security constraints only if tainting */
 336       if (sys) {
 337         /* Impose security constraints only if tainting */
 338         secure = PL_curinterp ? PL_tainting : will_taint;
 339         saverr = errno;  savvmserr = vaxc$errno;
 340       }
 341       else secure = 0;
 342       success = vmstrnenv(lnm,eqv,idx,
 343                           secure ? fildev : NULL,
 344 #ifdef SECURE_INTERNAL_GETENV
 345                           secure ? PERL__TRNENV_SECURE : 0
 346 #else
 347                           0
 348 #endif
 349                                                              );
 350       /* Discard NOLOGNAM on internal calls since we're often looking
 351        * for an optional name, and this "error" often shows up as the
 352        * (bogus) exit status for a die() call later on.  */
 353       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 354       return success ? eqv : Nullch;
 355     }
 356
 357 }  /* end of my_getenv() */
 358 /*}}}*/
 359
 360
 361 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 362 char *
 363 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 364 {
 365     char *buf, *cp1, *cp2;
 366     unsigned long idx = 0;
 367     static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
 368     int secure, saverr, savvmserr;
 369     SV *tmpsv;
 370
 371     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 372       /* Set up a temporary buffer for the return value; Perl will
 373        * clean it up at the next statement transition */
 374       tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
 375       if (!tmpsv) return NULL;
 376       buf = SvPVX(tmpsv);
 377     }
 378     else buf = __my_getenv_len_eqv;  /* Assume no interpreter ==> single thread */
 379     for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 380     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 381       getcwd(buf,LNM$C_NAMLENGTH);
 382       *len = strlen(buf);
 383       return buf;
 384     }
 385     else {
 386       if ((cp2 = strchr(lnm,';')) != NULL) {
 387         strcpy(buf,lnm);
 388         buf[cp2-lnm] = '\0';
 389         idx = strtoul(cp2+1,NULL,0);
 390         lnm = buf;
 391       }
 392       if (sys) {
 393         /* Impose security constraints only if tainting */
 394         secure = PL_curinterp ? PL_tainting : will_taint;
 395         saverr = errno;  savvmserr = vaxc$errno;
 396       }
 397       else secure = 0;
 398       *len = vmstrnenv(lnm,buf,idx,
 399                        secure ? fildev : NULL,
 400 #ifdef SECURE_INTERNAL_GETENV
 401                        secure ? PERL__TRNENV_SECURE : 0
 402 #else
 403                                                       0
 404 #endif
 405                                                        );
 406       /* Discard NOLOGNAM on internal calls since we're often looking
 407        * for an optional name, and this "error" often shows up as the
 408        * (bogus) exit status for a die() call later on.  */
 409       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 410       return *len ? buf : Nullch;
 411     }
 412
 413 }  /* end of my_getenv_len() */
 414 /*}}}*/
 415
 416 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 417
 418 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 419
 420 /*{{{ void prime_env_iter() */
 421 void
 422 prime_env_iter(void)
 423 /* Fill the %ENV associative array with all logical names we can
 424  * find, in preparation for iterating over it.
 425  */
 426 {
 427   static int primed = 0;
 428   HV *seenhv = NULL, *envhv;
 429   SV *sv = NULL;
 430   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 431   unsigned short int chan;
 432 #ifndef CLI$M_TRUSTED
 433 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 434 #endif
 435   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 436   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 437   long int i;
 438   bool have_sym = FALSE, have_lnm = FALSE;
 439   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 440   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 441   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 442   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 443   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 444 #if defined(PERL_IMPLICIT_CONTEXT)
 445   pTHX;
 446 #endif
 447 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
 448   static perl_mutex primenv_mutex;
 449   MUTEX_INIT(&primenv_mutex);
 450 #endif
 451
 452 #if defined(PERL_IMPLICIT_CONTEXT)
 453     /* We jump through these hoops because we can be called at */
 454     /* platform-specific initialization time, which is before anything is */
 455     /* set up--we can't even do a plain dTHX since that relies on the */
 456     /* interpreter structure to be initialized */
 457 #if defined(USE_5005THREADS)
 458     if (PL_curinterp) {
 459       aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
 460     } else {
 461       aTHX = NULL;
 462     }
 463 #else
 464     if (PL_curinterp) {
 465       aTHX = PERL_GET_INTERP;
 466     } else {
 467       aTHX = NULL;
 468     }
 469 #endif
 470 #endif
 471
 472   if (primed || !PL_envgv) return;
 473   MUTEX_LOCK(&primenv_mutex);
 474   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
 475   envhv = GvHVn(PL_envgv);
 476   /* Perform a dummy fetch as an lval to insure that the hash table is
 477    * set up.  Otherwise, the hv_store() will turn into a nullop. */
 478   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
 479
 480   for (i = 0; env_tables[i]; i++) {
 481      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 482          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
 483      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
 484   }
 485   if (have_sym || have_lnm) {
 486     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 487     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 488     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
 489     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
 490   }
 491
 492   for (i--; i >= 0; i--) {
 493     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
 494       char *start;
 495       int j;
 496       for (j = 0; environ[j]; j++) {
 497         if (!(start = strchr(environ[j],'='))) {
 498           if (ckWARN(WARN_INTERNAL))
 499             Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
 500         }
 501         else {
 502           start++;
 503           sv = newSVpv(start,0);
 504           SvTAINTED_on(sv);
 505           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
 506         }
 507       }
 508       continue;
 509     }
 510     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 511              !str$case_blind_compare(&tmpdsc,&clisym)) {
 512       strcpy(cmd,"Show Symbol/Global *");
 513       cmddsc.dsc$w_length = 20;
 514       if (env_tables[i]->dsc$w_length == 12 &&
 515           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
 516           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
 517       flags = defflags | CLI$M_NOLOGNAM;
 518     }
 519     else {
 520       strcpy(cmd,"Show Logical *");
 521       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
 522         strcat(cmd," /Table=");
 523         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
 524         cmddsc.dsc$w_length = strlen(cmd);
 525       }
 526       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
 527       flags = defflags | CLI$M_NOCLISYM;
 528     }
 529
 530     /* Create a new subprocess to execute each command, to exclude the
 531      * remote possibility that someone could subvert a mbx or file used
 532      * to write multiple commands to a single subprocess.
 533      */
 534     do {
 535       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
 536                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
 537       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
 538       defflags &= ~CLI$M_TRUSTED;
 539     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
 540     _ckvmssts(retsts);
 541     if (!buf) New(1322,buf,mbxbufsiz + 1,char);
 542     if (seenhv) SvREFCNT_dec(seenhv);
 543     seenhv = newHV();
 544     while (1) {
 545       char *cp1, *cp2, *key;
 546       unsigned long int sts, iosb[2], retlen, keylen;
 547       register U32 hash;
 548
 549       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
 550       if (sts & 1) sts = iosb[0] & 0xffff;
 551       if (sts == SS$_ENDOFFILE) {
 552         int wakect = 0;
 553         while (substs == 0) { sys$hiber(); wakect++;}
 554         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
 555         _ckvmssts(substs);
 556         break;
 557       }
 558       _ckvmssts(sts);
 559       retlen = iosb[0] >> 16;
 560       if (!retlen) continue;  /* blank line */
 561       buf[retlen] = '\0';
 562       if (iosb[1] != subpid) {
 563         if (iosb[1]) {
 564           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
 565         }
 566         continue;
 567       }
 568       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
 569         Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
 570
 571       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
 572       if (*cp1 == '(' || /* Logical name table name */
 573           *cp1 == '='    /* Next eqv of searchlist  */) continue;
 574       if (*cp1 == '"') cp1++;
 575       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
 576       key = cp1;  keylen = cp2 - cp1;
 577       if (keylen && hv_exists(seenhv,key,keylen)) continue;
 578       while (*cp2 && *cp2 != '=') cp2++;
 579       while (*cp2 && *cp2 == '=') cp2++;
 580       while (*cp2 && *cp2 == ' ') cp2++;
 581       if (*cp2 == '"') {  /* String translation; may embed "" */
 582         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
 583         cp2++;  cp1--; /* Skip "" surrounding translation */
 584       }
 585       else {  /* Numeric translation */
 586         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
 587         cp1--;  /* stop on last non-space char */
 588       }
 589       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
 590         Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
 591         continue;
 592       }
 593       PERL_HASH(hash,key,keylen);
 594       sv = newSVpvn(cp2,cp1 - cp2 + 1);
 595       SvTAINTED_on(sv);
 596       hv_store(envhv,key,keylen,sv,hash);
 597       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
 598     }
 599     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
 600       /* get the PPFs for this process, not the subprocess */
 601       char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
 602       char eqv[LNM$C_NAMLENGTH+1];
 603       int trnlen, i;
 604       for (i = 0; ppfs[i]; i++) {
 605         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
 606         sv = newSVpv(eqv,trnlen);
 607         SvTAINTED_on(sv);
 608         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
 609       }
 610     }
 611   }
 612   primed = 1;
 613   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
 614   if (buf) Safefree(buf);
 615   if (seenhv) SvREFCNT_dec(seenhv);
 616   MUTEX_UNLOCK(&primenv_mutex);
 617   return;
 618
 619 }  /* end of prime_env_iter */
 620 /*}}}*/
 621
 622
 623 /*{{{ int  vmssetenv(char *lnm, char *eqv)*/
 624 /* Define or delete an element in the same "environment" as
 625  * vmstrnenv().  If an element is to be deleted, it's removed from
 626  * the first place it's found.  If it's to be set, it's set in the
 627  * place designated by the first element of the table vector.
 628  * Like setenv() returns 0 for success, non-zero on error.
 629  */
 630 int
 631 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
 632 {
 633     char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
 634     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
 635     unsigned long int retsts, usermode = PSL$C_USER;
 636     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 637                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 638                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 639     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 640     $DESCRIPTOR(local,"_LOCAL");
 641
 642     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 643       *cp2 = _toupper(*cp1);
 644       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 645         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 646         return SS$_IVLOGNAM;
 647       }
 648     }
 649     lnmdsc.dsc$w_length = cp1 - lnm;
 650     if (!tabvec || !*tabvec) tabvec = env_tables;
 651
 652     if (!eqv) {  /* we're deleting n element */
 653       for (curtab = 0; tabvec[curtab]; curtab++) {
 654         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 655         int i;
 656           for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
 657             if ((cp1 = strchr(environ[i],'=')) &&
 658                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
 659 #ifdef HAS_SETENV
 660               return setenv(lnm,"",1) ? vaxc$errno : 0;
 661             }
 662           }
 663           ivenv = 1; retsts = SS$_NOLOGNAM;
 664 #else
 665               if (ckWARN(WARN_INTERNAL))
 666                 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
 667               ivenv = 1; retsts = SS$_NOSUCHPGM;
 668               break;
 669             }
 670           }
 671 #endif
 672         }
 673         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 674                  !str$case_blind_compare(&tmpdsc,&clisym)) {
 675           unsigned int symtype;
 676           if (tabvec[curtab]->dsc$w_length == 12 &&
 677               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
 678               !str$case_blind_compare(&tmpdsc,&local))
 679             symtype = LIB$K_CLI_LOCAL_SYM;
 680           else symtype = LIB$K_CLI_GLOBAL_SYM;
 681           retsts = lib$delete_symbol(&lnmdsc,&symtype);
 682           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 683           if (retsts == LIB$_NOSUCHSYM) continue;
 684           break;
 685         }
 686         else if (!ivlnm) {
 687           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
 688           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 689           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 690           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
 691           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 692         }
 693       }
 694     }
 695     else {  /* we're defining a value */
 696       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
 697 #ifdef HAS_SETENV
 698         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 699 #else
 700         if (ckWARN(WARN_INTERNAL))
 701           Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
 702         retsts = SS$_NOSUCHPGM;
 703 #endif
 704       }
 705       else {
 706         eqvdsc.dsc$a_pointer = eqv;
 707         eqvdsc.dsc$w_length  = strlen(eqv);
 708         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
 709             !str$case_blind_compare(&tmpdsc,&clisym)) {
 710           unsigned int symtype;
 711           if (tabvec[0]->dsc$w_length == 12 &&
 712               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
 713                !str$case_blind_compare(&tmpdsc,&local))
 714             symtype = LIB$K_CLI_LOCAL_SYM;
 715           else symtype = LIB$K_CLI_GLOBAL_SYM;
 716           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
 717         }
 718         else {
 719           if (!*eqv) eqvdsc.dsc$w_length = 1;
 720           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
 721             eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
 722             if (ckWARN(WARN_MISC)) {
 723               Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
 724             }
 725           }
 726           retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
 727         }
 728       }
 729     }
 730     if (!(retsts & 1)) {
 731       switch (retsts) {
 732         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
 733         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
 734           set_errno(EVMSERR); break;
 735         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
 736         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
 737           set_errno(EINVAL); break;
 738         case SS$_NOPRIV:
 739           set_errno(EACCES);
 740         default:
 741           _ckvmssts(retsts);
 742           set_errno(EVMSERR);
 743        }
 744        set_vaxc_errno(retsts);
 745        return (int) retsts || 44; /* retsts should never be 0, but just in case */
 746     }
 747     else {
 748       /* We reset error values on success because Perl does an hv_fetch()
 749        * before each hv_store(), and if the thing we're setting didn't
 750        * previously exist, we've got a leftover error message.  (Of course,
 751        * this fails in the face of
 752        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
 753        * in that the error reported in $! isn't spurious,
 754        * but it's right more often than not.)
 755        */
 756       set_errno(0); set_vaxc_errno(retsts);
 757       return 0;
 758     }
 759
 760 }  /* end of vmssetenv() */
 761 /*}}}*/
 762
 763 /*{{{ void  my_setenv(char *lnm, char *eqv)*/
 764 /* This has to be a function since there's a prototype for it in proto.h */
 765 void
 766 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
 767 {
 768     if (lnm && *lnm) {
 769       int len = strlen(lnm);
 770       if  (len == 7) {
 771         char uplnm[8];
 772         int i;
 773         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
 774         if (!strcmp(uplnm,"DEFAULT")) {
 775           if (eqv && *eqv) chdir(eqv);
 776           return;
 777         }
 778     }
 779 #ifndef RTL_USES_UTC
 780     if (len == 6 || len == 2) {
 781       char uplnm[7];
 782       int i;
 783       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
 784       uplnm[len] = '\0';
 785       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
 786       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
 787     }
 788 #endif
 789   }
 790   (void) vmssetenv(lnm,eqv,NULL);
 791 }
 792 /*}}}*/
 793
 794 /*{{{static void vmssetuserlnm(char *name, char *eqv);
 795 /*  vmssetuserlnm
 796  *  sets a user-mode logical in the process logical name table
 797  *  used for redirection of sys$error
 798  */
 799 void
 800 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
 801 {
 802     $DESCRIPTOR(d_tab, "LNM$PROCESS");
 803     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 804     unsigned long int iss, attr = LNM$M_CONFINE;
 805     unsigned char acmode = PSL$C_USER;
 806     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
 807                                  {0, 0, 0, 0}};
 808     d_name.dsc$a_pointer = name;
 809     d_name.dsc$w_length = strlen(name);
 810
 811     lnmlst[0].buflen = strlen(eqv);
 812     lnmlst[0].bufadr = eqv;
 813
 814     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
 815     if (!(iss&1)) lib$signal(iss);
 816 }
 817 /*}}}*/
 818
 819
 820 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
 821 /* my_crypt - VMS password hashing
 822  * my_crypt() provides an interface compatible with the Unix crypt()
 823  * C library function, and uses sys$hash_password() to perform VMS
 824  * password hashing.  The quadword hashed password value is returned
 825  * as a NUL-terminated 8 character string.  my_crypt() does not change
 826  * the case of its string arguments; in order to match the behavior
 827  * of LOGINOUT et al., alphabetic characters in both arguments must
 828  *  be upcased by the caller.
 829  */
 830 char *
 831 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
 832 {
 833 #   ifndef UAI$C_PREFERRED_ALGORITHM
 834 #     define UAI$C_PREFERRED_ALGORITHM 127
 835 #   endif
 836     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
 837     unsigned short int salt = 0;
 838     unsigned long int sts;
 839     struct const_dsc {
 840         unsigned short int dsc$w_length;
 841         unsigned char      dsc$b_type;
 842         unsigned char      dsc$b_class;
 843         const char *       dsc$a_pointer;
 844     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
 845        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 846     struct itmlst_3 uailst[3] = {
 847         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
 848         { sizeof salt, UAI$_SALT,    &salt, 0},
 849         { 0,           0,            NULL,  NULL}};
 850     static char hash[9];
 851
 852     usrdsc.dsc$w_length = strlen(usrname);
 853     usrdsc.dsc$a_pointer = usrname;
 854     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
 855       switch (sts) {
 856         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
 857           set_errno(EACCES);
 858           break;
 859         case RMS$_RNF:
 860           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
 861           break;
 862         default:
 863           set_errno(EVMSERR);
 864       }
 865       set_vaxc_errno(sts);
 866       if (sts != RMS$_RNF) return NULL;
 867     }
 868
 869     txtdsc.dsc$w_length = strlen(textpasswd);
 870     txtdsc.dsc$a_pointer = textpasswd;
 871     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
 872       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
 873     }
 874
 875     return (char *) hash;
 876
 877 }  /* end of my_crypt() */
 878 /*}}}*/
 879
 880
 881 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
 882 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
 883 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
 884
 885 /*{{{int do_rmdir(char *name)*/
 886 int
 887 Perl_do_rmdir(pTHX_ char *name)
 888 {
 889     char dirfile[NAM$C_MAXRSS+1];
 890     int retval;
 891     Stat_t st;
 892
 893     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
 894     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
 895     else retval = kill_file(dirfile);
 896     return retval;
 897
 898 }  /* end of do_rmdir */
 899 /*}}}*/
 900
 901 /* kill_file
 902  * Delete any file to which user has control access, regardless of whether
 903  * delete access is explicitly allowed.
 904  * Limitations: User must have write access to parent directory.
 905  *              Does not block signals or ASTs; if interrupted in midstream
 906  *              may leave file with an altered ACL.
 907  * HANDLE WITH CARE!
 908  */
 909 /*{{{int kill_file(char *name)*/
 910 int
 911 Perl_kill_file(pTHX_ char *name)
 912 {
 913     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
 914     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
 915     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
 916     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 917     struct myacedef {
 918       unsigned char myace$b_length;
 919       unsigned char myace$b_type;
 920       unsigned short int myace$w_flags;
 921       unsigned long int myace$l_access;
 922       unsigned long int myace$l_ident;
 923     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
 924                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
 925       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
 926      struct itmlst_3
 927        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
 928                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
 929        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
 930        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
 931        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
 932        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
 933
 934     /* Expand the input spec using RMS, since the CRTL remove() and
 935      * system services won't do this by themselves, so we may miss
 936      * a file "hiding" behind a logical name or search list. */
 937     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
 938     if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
 939     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
 940     /* If not, can changing protections help? */
 941     if (vaxc$errno != RMS$_PRV) return -1;
 942
 943     /* No, so we get our own UIC to use as a rights identifier,
 944      * and the insert an ACE at the head of the ACL which allows us
 945      * to delete the file.
 946      */
 947     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
 948     fildsc.dsc$w_length = strlen(rspec);
 949     fildsc.dsc$a_pointer = rspec;
 950     cxt = 0;
 951     newace.myace$l_ident = oldace.myace$l_ident;
 952     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
 953       switch (aclsts) {
 954         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
 955           set_errno(ENOENT); break;
 956         case RMS$_DIR:
 957           set_errno(ENOTDIR); break;
 958         case RMS$_DEV:
 959           set_errno(ENODEV); break;
 960         case RMS$_SYN: case SS$_INVFILFOROP:
 961           set_errno(EINVAL); break;
 962         case RMS$_PRV:
 963           set_errno(EACCES); break;
 964         default:
 965           _ckvmssts(aclsts);
 966       }
 967       set_vaxc_errno(aclsts);
 968       return -1;
 969     }
 970     /* Grab any existing ACEs with this identifier in case we fail */
 971     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
 972     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
 973                     || fndsts == SS$_NOMOREACE ) {
 974       /* Add the new ACE . . . */
 975       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
 976         goto yourroom;
 977       if ((rmsts = remove(name))) {
 978         /* We blew it - dir with files in it, no write priv for
 979          * parent directory, etc.  Put things back the way they were. */
 980         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
 981           goto yourroom;
 982         if (fndsts & 1) {
 983           addlst[0].bufadr = &oldace;
 984           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
 985             goto yourroom;
 986         }
 987       }
 988     }
 989
 990     yourroom:
 991     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
 992     /* We just deleted it, so of course it's not there.  Some versions of
 993      * VMS seem to return success on the unlock operation anyhow (after all
 994      * the unlock is successful), but others don't.
 995      */
 996     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
 997     if (aclsts & 1) aclsts = fndsts;
 998     if (!(aclsts & 1)) {
 999       set_errno(EVMSERR);
1000       set_vaxc_errno(aclsts);
1001       return -1;
1002     }
1003
1004     return rmsts;
1005
1006 }  /* end of kill_file() */
1007 /*}}}*/
1008
1009
1010 /*{{{int my_mkdir(char *,Mode_t)*/
1011 int
1012 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1013 {
1014   STRLEN dirlen = strlen(dir);
1015
1016   /* zero length string sometimes gives ACCVIO */
1017   if (dirlen == 0) return -1;
1018
1019   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1020    * null file name/type.  However, it's commonplace under Unix,
1021    * so we'll allow it for a gain in portability.
1022    */
1023   if (dir[dirlen-1] == '/') {
1024     char *newdir = savepvn(dir,dirlen-1);
1025     int ret = mkdir(newdir,mode);
1026     Safefree(newdir);
1027     return ret;
1028   }
1029   else return mkdir(dir,mode);
1030 }  /* end of my_mkdir */
1031 /*}}}*/
1032
1033 /*{{{int my_chdir(char *)*/
1034 int
1035 Perl_my_chdir(pTHX_ char *dir)
1036 {
1037   STRLEN dirlen = strlen(dir);
1038
1039   /* zero length string sometimes gives ACCVIO */
1040   if (dirlen == 0) return -1;
1041
1042   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1043    * that implies
1044    * null file name/type.  However, it's commonplace under Unix,
1045    * so we'll allow it for a gain in portability.
1046    */
1047   if (dir[dirlen-1] == '/') {
1048     char *newdir = savepvn(dir,dirlen-1);
1049     int ret = chdir(newdir);
1050     Safefree(newdir);
1051     return ret;
1052   }
1053   else return chdir(dir);
1054 }  /* end of my_chdir */
1055 /*}}}*/
1056
1057
1058 /*{{{FILE *my_tmpfile()*/
1059 FILE *
1060 my_tmpfile(void)
1061 {
1062   FILE *fp;
1063   char *cp;
1064
1065   if ((fp = tmpfile())) return fp;
1066
1067   New(1323,cp,L_tmpnam+24,char);
1068   strcpy(cp,"Sys$Scratch:");
1069   tmpnam(cp+strlen(cp));
1070   strcat(cp,".Perltmp");
1071   fp = fopen(cp,"w+","fop=dlt");
1072   Safefree(cp);
1073   return fp;
1074 }
1075 /*}}}*/
1076
1077
1078 #ifndef HOMEGROWN_POSIX_SIGNALS
1079 /*
1080  * The C RTL's sigaction fails to check for invalid signal numbers so we
1081  * help it out a bit.  The docs are correct, but the actual routine doesn't
1082  * do what the docs say it will.
1083  */
1084 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1085 int
1086 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1087                    struct sigaction* oact)
1088 {
1089   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1090         SETERRNO(EINVAL, SS$_INVARG);
1091         return -1;
1092   }
1093   return sigaction(sig, act, oact);
1094 }
1095 /*}}}*/
1096 #endif
1097
1098 /* default piping mailbox size */
1099 #define PERL_BUFSIZ        512
1100
1101
1102 static void
1103 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1104 {
1105   unsigned long int mbxbufsiz;
1106   static unsigned long int syssize = 0;
1107   unsigned long int dviitm = DVI$_DEVNAM;
1108   char csize[LNM$C_NAMLENGTH+1];
1109
1110   if (!syssize) {
1111     unsigned long syiitm = SYI$_MAXBUF;
1112     /*
1113      * Get the SYSGEN parameter MAXBUF
1114      *
1115      * If the logical 'PERL_MBX_SIZE' is defined
1116      * use the value of the logical instead of PERL_BUFSIZ, but
1117      * keep the size between 128 and MAXBUF.
1118      *
1119      */
1120     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1121   }
1122
1123   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1124       mbxbufsiz = atoi(csize);
1125   } else {
1126       mbxbufsiz = PERL_BUFSIZ;
1127   }
1128   if (mbxbufsiz < 128) mbxbufsiz = 128;
1129   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1130
1131   _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1132
1133   _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1134   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1135
1136 }  /* end of create_mbx() */
1137
1138
1139 /*{{{  my_popen and my_pclose*/
1140
1141 typedef struct _iosb           IOSB;
1142 typedef struct _iosb*         pIOSB;
1143 typedef struct _pipe           Pipe;
1144 typedef struct _pipe*         pPipe;
1145 typedef struct pipe_details    Info;
1146 typedef struct pipe_details*  pInfo;
1147 typedef struct _srqp            RQE;
1148 typedef struct _srqp*          pRQE;
1149 typedef struct _tochildbuf      CBuf;
1150 typedef struct _tochildbuf*    pCBuf;
1151
1152 struct _iosb {
1153     unsigned short status;
1154     unsigned short count;
1155     unsigned long  dvispec;
1156 };
1157
1158 #pragma member_alignment save
1159 #pragma nomember_alignment quadword
1160 struct _srqp {          /* VMS self-relative queue entry */
1161     unsigned long qptr[2];
1162 };
1163 #pragma member_alignment restore
1164 static RQE  RQE_ZERO = {0,0};
1165
1166 struct _tochildbuf {
1167     RQE             q;
1168     int             eof;
1169     unsigned short  size;
1170     char            *buf;
1171 };
1172
1173 struct _pipe {
1174     RQE            free;
1175     RQE            wait;
1176     int            fd_out;
1177     unsigned short chan_in;
1178     unsigned short chan_out;
1179     char          *buf;
1180     unsigned int   bufsize;
1181     IOSB           iosb;
1182     IOSB           iosb2;
1183     int           *pipe_done;
1184     int            retry;
1185     int            type;
1186     int            shut_on_empty;
1187     int            need_wake;
1188     pPipe         *home;
1189     pInfo          info;
1190     pCBuf          curr;
1191     pCBuf          curr2;
1192 #if defined(PERL_IMPLICIT_CONTEXT)
1193     void            *thx;           /* Either a thread or an interpreter */
1194                                     /* pointer, depending on how we're built */
1195 #endif
1196 };
1197
1198
1199 struct pipe_details
1200 {
1201     pInfo           next;
1202     PerlIO *fp;  /* file pointer to pipe mailbox */
1203     int useFILE; /* using stdio, not perlio */
1204     int pid;   /* PID of subprocess */
1205     int mode;  /* == 'r' if pipe open for reading */
1206     int done;  /* subprocess has completed */
1207     int waiting; /* waiting for completion/closure */
1208     int             closing;        /* my_pclose is closing this pipe */
1209     unsigned long   completion;     /* termination status of subprocess */
1210     pPipe           in;             /* pipe in to sub */
1211     pPipe           out;            /* pipe out of sub */
1212     pPipe           err;            /* pipe of sub's sys$error */
1213     int             in_done;        /* true when in pipe finished */
1214     int             out_done;
1215     int             err_done;
1216 };
1217
1218 struct exit_control_block
1219 {
1220     struct exit_control_block *flink;
1221     unsigned long int   (*exit_routine)();
1222     unsigned long int arg_count;
1223     unsigned long int *status_address;
1224     unsigned long int exit_status;
1225 };
1226
1227 #define RETRY_DELAY     "0 ::0.20"
1228 #define MAX_RETRY              50
1229
1230 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
1231 static unsigned long mypid;
1232 static unsigned long delaytime[2];
1233
1234 static pInfo open_pipes = NULL;
1235 static $DESCRIPTOR(nl_desc, "NL:");
1236
1237 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
1238
1239
1240
1241 static unsigned long int
1242 pipe_exit_routine(pTHX)
1243 {
1244     pInfo info;
1245     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1246     int sts, did_stuff, need_eof, j;
1247
1248     /*
1249         flush any pending i/o
1250     */
1251     info = open_pipes;
1252     while (info) {
1253         if (info->fp) {
1254            if (!info->useFILE)
1255                PerlIO_flush(info->fp);   /* first, flush data */
1256            else
1257                fflush((FILE *)info->fp);
1258         }
1259         info = info->next;
1260     }
1261
1262     /*
1263      next we try sending an EOF...ignore if doesn't work, make sure we
1264      don't hang
1265     */
1266     did_stuff = 0;
1267     info = open_pipes;
1268
1269     while (info) {
1270       int need_eof;
1271       _ckvmssts(sys$setast(0));
1272       if (info->in && !info->in->shut_on_empty) {
1273         _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1274                           0, 0, 0, 0, 0, 0));
1275         info->waiting = 1;
1276         did_stuff = 1;
1277       }
1278       _ckvmssts(sys$setast(1));
1279       info = info->next;
1280     }
1281
1282     /* wait for EOF to have effect, up to ~ 30 sec [default] */
1283
1284     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1285         int nwait = 0;
1286
1287         info = open_pipes;
1288         while (info) {
1289           _ckvmssts(sys$setast(0));
1290           if (info->waiting && info->done)
1291                 info->waiting = 0;
1292           nwait += info->waiting;
1293           _ckvmssts(sys$setast(1));
1294           info = info->next;
1295         }
1296         if (!nwait) break;
1297         sleep(1);
1298     }
1299
1300     did_stuff = 0;
1301     info = open_pipes;
1302     while (info) {
1303       _ckvmssts(sys$setast(0));
1304       if (!info->done) { /* Tap them gently on the shoulder . . .*/
1305         sts = sys$forcex(&info->pid,0,&abort);
1306         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1307         did_stuff = 1;
1308       }
1309       _ckvmssts(sys$setast(1));
1310       info = info->next;
1311     }
1312
1313     /* again, wait for effect */
1314
1315     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1316         int nwait = 0;
1317
1318         info = open_pipes;
1319         while (info) {
1320           _ckvmssts(sys$setast(0));
1321           if (info->waiting && info->done)
1322                 info->waiting = 0;
1323           nwait += info->waiting;
1324           _ckvmssts(sys$setast(1));
1325           info = info->next;
1326         }
1327         if (!nwait) break;
1328         sleep(1);
1329     }
1330
1331     info = open_pipes;
1332     while (info) {
1333       _ckvmssts(sys$setast(0));
1334       if (!info->done) {  /* We tried to be nice . . . */
1335         sts = sys$delprc(&info->pid,0);
1336         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1337       }
1338       _ckvmssts(sys$setast(1));
1339       info = info->next;
1340     }
1341
1342     while(open_pipes) {
1343       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1344       else if (!(sts & 1)) retsts = sts;
1345     }
1346     return retsts;
1347 }
1348
1349 static struct exit_control_block pipe_exitblock =
1350        {(struct exit_control_block *) 0,
1351         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1352
1353 static void pipe_mbxtofd_ast(pPipe p);
1354 static void pipe_tochild1_ast(pPipe p);
1355 static void pipe_tochild2_ast(pPipe p);
1356
1357 static void
1358 popen_completion_ast(pInfo info)
1359 {
1360   pInfo i = open_pipes;
1361   int iss;
1362
1363   while (i) {
1364     if (i == info) break;
1365     i = i->next;
1366   }
1367   if (!i) return;       /* unlinked, probably freed too */
1368
1369   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1370   info->done = TRUE;
1371
1372 /*
1373     Writing to subprocess ...
1374             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1375
1376             chan_out may be waiting for "done" flag, or hung waiting
1377             for i/o completion to child...cancel the i/o.  This will
1378             put it into "snarf mode" (done but no EOF yet) that discards
1379             input.
1380
1381     Output from subprocess (stdout, stderr) needs to be flushed and
1382     shut down.   We try sending an EOF, but if the mbx is full the pipe
1383     routine should still catch the "shut_on_empty" flag, telling it to
1384     use immediate-style reads so that "mbx empty" -> EOF.
1385
1386
1387 */
1388   if (info->in && !info->in_done) {               /* only for mode=w */
1389         if (info->in->shut_on_empty && info->in->need_wake) {
1390             info->in->need_wake = FALSE;
1391             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1392         } else {
1393             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1394         }
1395   }
1396
1397   if (info->out && !info->out_done) {             /* were we also piping output? */
1398       info->out->shut_on_empty = TRUE;
1399       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1400       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1401       _ckvmssts_noperl(iss);
1402   }
1403
1404   if (info->err && !info->err_done) {        /* we were piping stderr */
1405         info->err->shut_on_empty = TRUE;
1406         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1407         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1408         _ckvmssts_noperl(iss);
1409   }
1410   _ckvmssts_noperl(sys$setef(pipe_ef));
1411
1412 }
1413
1414 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote);
1415 static void vms_execfree(pTHX);
1416
1417 /*
1418     we actually differ from vmstrnenv since we use this to
1419     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1420     are pointing to the same thing
1421 */
1422
1423 static unsigned short
1424 popen_translate(pTHX_ char *logical, char *result)
1425 {
1426     int iss;
1427     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1428     $DESCRIPTOR(d_log,"");
1429     struct _il3 {
1430         unsigned short length;
1431         unsigned short code;
1432         char *         buffer_addr;
1433         unsigned short *retlenaddr;
1434     } itmlst[2];
1435     unsigned short l, ifi;
1436
1437     d_log.dsc$a_pointer = logical;
1438     d_log.dsc$w_length  = strlen(logical);
1439
1440     itmlst[0].code = LNM$_STRING;
1441     itmlst[0].length = 255;
1442     itmlst[0].buffer_addr = result;
1443     itmlst[0].retlenaddr = &l;
1444
1445     itmlst[1].code = 0;
1446     itmlst[1].length = 0;
1447     itmlst[1].buffer_addr = 0;
1448     itmlst[1].retlenaddr = 0;
1449
1450     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1451     if (iss == SS$_NOLOGNAM) {
1452         iss = SS$_NORMAL;
1453         l = 0;
1454     }
1455     if (!(iss&1)) lib$signal(iss);
1456     result[l] = '\0';
1457 /*
1458     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
1459     strip it off and return the ifi, if any
1460 */
1461     ifi  = 0;
1462     if (result[0] == 0x1b && result[1] == 0x00) {
1463         memcpy(&ifi,result+2,2);
1464         strcpy(result,result+4);
1465     }
1466     return ifi;     /* this is the RMS internal file id */
1467 }
1468
1469 #define MAX_DCL_SYMBOL        255
1470 static void pipe_infromchild_ast(pPipe p);
1471
1472 /*
1473     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1474     inside an AST routine without worrying about reentrancy and which Perl
1475     memory allocator is being used.
1476
1477     We read data and queue up the buffers, then spit them out one at a
1478     time to the output mailbox when the output mailbox is ready for one.
1479
1480 */
1481 #define INITIAL_TOCHILDQUEUE  2
1482
1483 static pPipe
1484 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1485 {
1486     pPipe p;
1487     pCBuf b;
1488     char mbx1[64], mbx2[64];
1489     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1490                                       DSC$K_CLASS_S, mbx1},
1491                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1492                                       DSC$K_CLASS_S, mbx2};
1493     unsigned int dviitm = DVI$_DEVBUFSIZ;
1494     int j, n;
1495
1496     New(1368, p, 1, Pipe);
1497
1498     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1499     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1500     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1501
1502     p->buf           = 0;
1503     p->shut_on_empty = FALSE;
1504     p->need_wake     = FALSE;
1505     p->type          = 0;
1506     p->retry         = 0;
1507     p->iosb.status   = SS$_NORMAL;
1508     p->iosb2.status  = SS$_NORMAL;
1509     p->free          = RQE_ZERO;
1510     p->wait          = RQE_ZERO;
1511     p->curr          = 0;
1512     p->curr2         = 0;
1513     p->info          = 0;
1514 #ifdef PERL_IMPLICIT_CONTEXT
1515     p->thx           = aTHX;
1516 #endif
1517
1518     n = sizeof(CBuf) + p->bufsize;
1519
1520     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1521         _ckvmssts(lib$get_vm(&n, &b));
1522         b->buf = (char *) b + sizeof(CBuf);
1523         _ckvmssts(lib$insqhi(b, &p->free));
1524     }
1525
1526     pipe_tochild2_ast(p);
1527     pipe_tochild1_ast(p);
1528     strcpy(wmbx, mbx1);
1529     strcpy(rmbx, mbx2);
1530     return p;
1531 }
1532
1533 /*  reads the MBX Perl is writing, and queues */
1534
1535 static void
1536 pipe_tochild1_ast(pPipe p)
1537 {
1538     pCBuf b = p->curr;
1539     int iss = p->iosb.status;
1540     int eof = (iss == SS$_ENDOFFILE);
1541 #ifdef PERL_IMPLICIT_CONTEXT
1542     pTHX = p->thx;
1543 #endif
1544
1545     if (p->retry) {
1546         if (eof) {
1547             p->shut_on_empty = TRUE;
1548             b->eof     = TRUE;
1549             _ckvmssts(sys$dassgn(p->chan_in));
1550         } else  {
1551             _ckvmssts(iss);
1552         }
1553
1554         b->eof  = eof;
1555         b->size = p->iosb.count;
1556         _ckvmssts(lib$insqhi(b, &p->wait));
1557         if (p->need_wake) {
1558             p->need_wake = FALSE;
1559             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1560         }
1561     } else {
1562         p->retry = 1;   /* initial call */
1563     }
1564
1565     if (eof) {                  /* flush the free queue, return when done */
1566         int n = sizeof(CBuf) + p->bufsize;
1567         while (1) {
1568             iss = lib$remqti(&p->free, &b);
1569             if (iss == LIB$_QUEWASEMP) return;
1570             _ckvmssts(iss);
1571             _ckvmssts(lib$free_vm(&n, &b));
1572         }
1573     }
1574
1575     iss = lib$remqti(&p->free, &b);
1576     if (iss == LIB$_QUEWASEMP) {
1577         int n = sizeof(CBuf) + p->bufsize;
1578         _ckvmssts(lib$get_vm(&n, &b));
1579         b->buf = (char *) b + sizeof(CBuf);
1580     } else {
1581        _ckvmssts(iss);
1582     }
1583
1584     p->curr = b;
1585     iss = sys$qio(0,p->chan_in,
1586              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1587              &p->iosb,
1588              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1589     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1590     _ckvmssts(iss);
1591 }
1592
1593
1594 /* writes queued buffers to output, waits for each to complete before
1595    doing the next */
1596
1597 static void
1598 pipe_tochild2_ast(pPipe p)
1599 {
1600     pCBuf b = p->curr2;
1601     int iss = p->iosb2.status;
1602     int n = sizeof(CBuf) + p->bufsize;
1603     int done = (p->info && p->info->done) ||
1604               iss == SS$_CANCEL || iss == SS$_ABORT;
1605 #if defined(PERL_IMPLICIT_CONTEXT)
1606     pTHX = p->thx;
1607 #endif
1608
1609     do {
1610         if (p->type) {         /* type=1 has old buffer, dispose */
1611             if (p->shut_on_empty) {
1612                 _ckvmssts(lib$free_vm(&n, &b));
1613             } else {
1614                 _ckvmssts(lib$insqhi(b, &p->free));
1615             }
1616             p->type = 0;
1617         }
1618
1619         iss = lib$remqti(&p->wait, &b);
1620         if (iss == LIB$_QUEWASEMP) {
1621             if (p->shut_on_empty) {
1622                 if (done) {
1623                     _ckvmssts(sys$dassgn(p->chan_out));
1624                     *p->pipe_done = TRUE;
1625                     _ckvmssts(sys$setef(pipe_ef));
1626                 } else {
1627                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1628                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1629                 }
1630                 return;
1631             }
1632             p->need_wake = TRUE;
1633             return;
1634         }
1635         _ckvmssts(iss);
1636         p->type = 1;
1637     } while (done);
1638
1639
1640     p->curr2 = b;
1641     if (b->eof) {
1642         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1643             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1644     } else {
1645         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1646             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1647     }
1648
1649     return;
1650
1651 }
1652
1653
1654 static pPipe
1655 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1656 {
1657     pPipe p;
1658     char mbx1[64], mbx2[64];
1659     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1660                                       DSC$K_CLASS_S, mbx1},
1661                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1662                                       DSC$K_CLASS_S, mbx2};
1663     unsigned int dviitm = DVI$_DEVBUFSIZ;
1664
1665     New(1367, p, 1, Pipe);
1666     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1667     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1668
1669     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1670     New(1367, p->buf, p->bufsize, char);
1671     p->shut_on_empty = FALSE;
1672     p->info   = 0;
1673     p->type   = 0;
1674     p->iosb.status = SS$_NORMAL;
1675 #if defined(PERL_IMPLICIT_CONTEXT)
1676     p->thx = aTHX;
1677 #endif
1678     pipe_infromchild_ast(p);
1679
1680     strcpy(wmbx, mbx1);
1681     strcpy(rmbx, mbx2);
1682     return p;
1683 }
1684
1685 static void
1686 pipe_infromchild_ast(pPipe p)
1687 {
1688     int iss = p->iosb.status;
1689     int eof = (iss == SS$_ENDOFFILE);
1690     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1691     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1692 #if defined(PERL_IMPLICIT_CONTEXT)
1693     pTHX = p->thx;
1694 #endif
1695
1696     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
1697         _ckvmssts(sys$dassgn(p->chan_out));
1698         p->chan_out = 0;
1699     }
1700
1701     /* read completed:
1702             input shutdown if EOF from self (done or shut_on_empty)
1703             output shutdown if closing flag set (my_pclose)
1704             send data/eof from child or eof from self
1705             otherwise, re-read (snarf of data from child)
1706     */
1707
1708     if (p->type == 1) {
1709         p->type = 0;
1710         if (myeof && p->chan_in) {                  /* input shutdown */
1711             _ckvmssts(sys$dassgn(p->chan_in));
1712             p->chan_in = 0;
1713         }
1714
1715         if (p->chan_out) {
1716             if (myeof || kideof) {      /* pass EOF to parent */
1717                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1718                               pipe_infromchild_ast, p,
1719                               0, 0, 0, 0, 0, 0));
1720                 return;
1721             } else if (eof) {       /* eat EOF --- fall through to read*/
1722
1723             } else {                /* transmit data */
1724                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1725                               pipe_infromchild_ast,p,
1726                               p->buf, p->iosb.count, 0, 0, 0, 0));
1727                 return;
1728             }
1729         }
1730     }
1731
1732     /*  everything shut? flag as done */
1733
1734     if (!p->chan_in && !p->chan_out) {
1735         *p->pipe_done = TRUE;
1736         _ckvmssts(sys$setef(pipe_ef));
1737         return;
1738     }
1739
1740     /* write completed (or read, if snarfing from child)
1741             if still have input active,
1742                queue read...immediate mode if shut_on_empty so we get EOF if empty
1743             otherwise,
1744                check if Perl reading, generate EOFs as needed
1745     */
1746
1747     if (p->type == 0) {
1748         p->type = 1;
1749         if (p->chan_in) {
1750             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1751                           pipe_infromchild_ast,p,
1752                           p->buf, p->bufsize, 0, 0, 0, 0);
1753             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1754             _ckvmssts(iss);
1755         } else {           /* send EOFs for extra reads */
1756             p->iosb.status = SS$_ENDOFFILE;
1757             p->iosb.dvispec = 0;
1758             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1759                       0, 0, 0,
1760                       pipe_infromchild_ast, p, 0, 0, 0, 0));
1761         }
1762     }
1763 }
1764
1765 static pPipe
1766 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1767 {
1768     pPipe p;
1769     char mbx[64];
1770     unsigned long dviitm = DVI$_DEVBUFSIZ;
1771     struct stat s;
1772     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1773                                       DSC$K_CLASS_S, mbx};
1774
1775     /* things like terminals and mbx's don't need this filter */
1776     if (fd && fstat(fd,&s) == 0) {
1777         unsigned long dviitm = DVI$_DEVCHAR, devchar;
1778         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1779                                          DSC$K_CLASS_S, s.st_dev};
1780
1781         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1782         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
1783             strcpy(out, s.st_dev);
1784             return 0;
1785         }
1786     }
1787
1788     New(1366, p, 1, Pipe);
1789     p->fd_out = dup(fd);
1790     create_mbx(aTHX_ &p->chan_in, &d_mbx);
1791     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1792     New(1366, p->buf, p->bufsize+1, char);
1793     p->shut_on_empty = FALSE;
1794     p->retry = 0;
1795     p->info  = 0;
1796     strcpy(out, mbx);
1797
1798     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1799                   pipe_mbxtofd_ast, p,
1800                   p->buf, p->bufsize, 0, 0, 0, 0));
1801
1802     return p;
1803 }
1804
1805 static void
1806 pipe_mbxtofd_ast(pPipe p)
1807 {
1808     int iss = p->iosb.status;
1809     int done = p->info->done;
1810     int iss2;
1811     int eof = (iss == SS$_ENDOFFILE);
1812     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1813     int err = !(iss&1) && !eof;
1814 #if defined(PERL_IMPLICIT_CONTEXT)
1815     pTHX = p->thx;
1816 #endif
1817
1818     if (done && myeof) {               /* end piping */
1819         close(p->fd_out);
1820         sys$dassgn(p->chan_in);
1821         *p->pipe_done = TRUE;
1822         _ckvmssts(sys$setef(pipe_ef));
1823         return;
1824     }
1825
1826     if (!err && !eof) {             /* good data to send to file */
1827         p->buf[p->iosb.count] = '\n';
1828         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1829         if (iss2 < 0) {
1830             p->retry++;
1831             if (p->retry < MAX_RETRY) {
1832                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1833                 return;
1834             }
1835         }
1836         p->retry = 0;
1837     } else if (err) {
1838         _ckvmssts(iss);
1839     }
1840
1841
1842     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1843           pipe_mbxtofd_ast, p,
1844           p->buf, p->bufsize, 0, 0, 0, 0);
1845     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1846     _ckvmssts(iss);
1847 }
1848
1849
1850 typedef struct _pipeloc     PLOC;
1851 typedef struct _pipeloc*   pPLOC;
1852
1853 struct _pipeloc {
1854     pPLOC   next;
1855     char    dir[NAM$C_MAXRSS+1];
1856 };
1857 static pPLOC  head_PLOC = 0;
1858
1859 void
1860 free_pipelocs(pTHX_ void *head)
1861 {
1862     pPLOC p, pnext;
1863     pPLOC *pHead = (pPLOC *)head;
1864
1865     p = *pHead;
1866     while (p) {
1867         pnext = p->next;
1868         Safefree(p);
1869         p = pnext;
1870     }
1871     *pHead = 0;
1872 }
1873
1874 static void
1875 store_pipelocs(pTHX)
1876 {
1877     int    i;
1878     pPLOC  p;
1879     AV    *av = 0;
1880     SV    *dirsv;
1881     GV    *gv;
1882     char  *dir, *x;
1883     char  *unixdir;
1884     char  temp[NAM$C_MAXRSS+1];
1885     STRLEN n_a;
1886
1887     if (head_PLOC)
1888         free_pipelocs(&head_PLOC);
1889
1890 /*  the . directory from @INC comes last */
1891
1892     New(1370,p,1,PLOC);
1893     p->next = head_PLOC;
1894     head_PLOC = p;
1895     strcpy(p->dir,"./");
1896
1897 /*  get the directory from $^X */
1898
1899     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
1900         strcpy(temp, PL_origargv[0]);
1901         x = strrchr(temp,']');
1902         if (x) x[1] = '\0';
1903
1904         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1905             New(1370,p,1,PLOC);
1906             p->next = head_PLOC;
1907             head_PLOC = p;
1908             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1909             p->dir[NAM$C_MAXRSS] = '\0';
1910         }
1911     }
1912
1913 /*  reverse order of @INC entries, skip "." since entered above */
1914
1915     if (PL_incgv) av = GvAVn(PL_incgv);
1916
1917     for (i = 0; av && i <= AvFILL(av); i++) {
1918         dirsv = *av_fetch(av,i,TRUE);
1919
1920         if (SvROK(dirsv)) continue;
1921         dir = SvPVx(dirsv,n_a);
1922         if (strcmp(dir,".") == 0) continue;
1923         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1924             continue;
1925
1926         New(1370,p,1,PLOC);
1927         p->next = head_PLOC;
1928         head_PLOC = p;
1929         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1930         p->dir[NAM$C_MAXRSS] = '\0';
1931     }
1932
1933 /* most likely spot (ARCHLIB) put first in the list */
1934
1935 #ifdef ARCHLIB_EXP
1936     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1937         New(1370,p,1,PLOC);
1938         p->next = head_PLOC;
1939         head_PLOC = p;
1940         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1941         p->dir[NAM$C_MAXRSS] = '\0';
1942     }
1943 #endif
1944     Perl_call_atexit(aTHX_ &free_pipelocs, &head_PLOC);
1945 }
1946
1947
1948 static char *
1949 find_vmspipe(pTHX)
1950 {
1951     static int   vmspipe_file_status = 0;
1952     static char  vmspipe_file[NAM$C_MAXRSS+1];
1953
1954     /* already found? Check and use ... need read+execute permission */
1955
1956     if (vmspipe_file_status == 1) {
1957         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1958          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1959             return vmspipe_file;
1960         }
1961         vmspipe_file_status = 0;
1962     }
1963
1964     /* scan through stored @INC, $^X */
1965
1966     if (vmspipe_file_status == 0) {
1967         char file[NAM$C_MAXRSS+1];
1968         pPLOC  p = head_PLOC;
1969
1970         while (p) {
1971             strcpy(file, p->dir);
1972             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1973             file[NAM$C_MAXRSS] = '\0';
1974             p = p->next;
1975
1976             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1977
1978             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1979              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1980                 vmspipe_file_status = 1;
1981                 return vmspipe_file;
1982             }
1983         }
1984         vmspipe_file_status = -1;   /* failed, use tempfiles */
1985     }
1986
1987     return 0;
1988 }
1989
1990 static FILE *
1991 vmspipe_tempfile(pTHX)
1992 {
1993     char file[NAM$C_MAXRSS+1];
1994     FILE *fp;
1995     static int index = 0;
1996     stat_t s0, s1;
1997
1998     /* create a tempfile */
1999
2000     /* we can't go from   W, shr=get to  R, shr=get without
2001        an intermediate vulnerable state, so don't bother trying...
2002
2003        and lib$spawn doesn't shr=put, so have to close the write
2004
2005        So... match up the creation date/time and the FID to
2006        make sure we're dealing with the same file
2007
2008     */
2009
2010     index++;
2011     sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2012     fp = fopen(file,"w");
2013     if (!fp) {
2014         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2015         fp = fopen(file,"w");
2016         if (!fp) {
2017             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2018             fp = fopen(file,"w");
2019         }
2020     }
2021     if (!fp) return 0;  /* we're hosed */
2022
2023     fprintf(fp,"$! 'f$verify(0)\n");
2024     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
2025     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
2026     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2027     fprintf(fp,"$ perl_on     = \"set noon\"\n");
2028     fprintf(fp,"$ perl_exit   = \"exit\"\n");
2029     fprintf(fp,"$ perl_del    = \"delete\"\n");
2030     fprintf(fp,"$ pif         = \"if\"\n");
2031     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
2032     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
2033     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
2034     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
2035     fprintf(fp,"$ cmd = perl_popen_cmd\n");
2036     fprintf(fp,"$!  --- get rid of global symbols\n");
2037     fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
2038     fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
2039     fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
2040     fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
2041     fprintf(fp,"$ perl_on\n");
2042     fprintf(fp,"$ 'cmd\n");
2043     fprintf(fp,"$ perl_status = $STATUS\n");
2044     fprintf(fp,"$ perl_del  'perl_cfile'\n");
2045     fprintf(fp,"$ perl_exit 'perl_status'\n");
2046     fsync(fileno(fp));
2047
2048     fgetname(fp, file, 1);
2049     fstat(fileno(fp), &s0);
2050     fclose(fp);
2051
2052     fp = fopen(file,"r","shr=get");
2053     if (!fp) return 0;
2054     fstat(fileno(fp), &s1);
2055
2056     if (s0.st_ino[0] != s1.st_ino[0] ||
2057         s0.st_ino[1] != s1.st_ino[1] ||
2058         s0.st_ino[2] != s1.st_ino[2] ||
2059         s0.st_ctime  != s1.st_ctime  )  {
2060         fclose(fp);
2061         return 0;
2062     }
2063
2064     return fp;
2065 }
2066
2067
2068
2069 static PerlIO *
2070 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2071 {
2072     static int handler_set_up = FALSE;
2073     unsigned long int sts, flags=1;  /* nowait - gnu c doesn't allow &1 */
2074     unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2075     int wait = 0;
2076     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2077     char in[512], out[512], err[512], mbx[512];
2078     FILE *tpipe = 0;
2079     char tfilebuf[NAM$C_MAXRSS+1];
2080     pInfo info;
2081     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2082                                       DSC$K_CLASS_S, symbol};
2083     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2084                                       DSC$K_CLASS_S, 0};
2085
2086     $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
2087     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2088     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2089     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2090
2091     /* once-per-program initialization...
2092        note that the SETAST calls and the dual test of pipe_ef
2093        makes sure that only the FIRST thread through here does
2094        the initialization...all other threads wait until it's
2095        done.
2096
2097        Yeah, uglier than a pthread call, it's got all the stuff inline
2098        rather than in a separate routine.
2099     */
2100
2101     if (!pipe_ef) {
2102         _ckvmssts(sys$setast(0));
2103         if (!pipe_ef) {
2104             unsigned long int pidcode = JPI$_PID;
2105             $DESCRIPTOR(d_delay, RETRY_DELAY);
2106             _ckvmssts(lib$get_ef(&pipe_ef));
2107             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2108             _ckvmssts(sys$bintim(&d_delay, delaytime));
2109         }
2110         if (!handler_set_up) {
2111           _ckvmssts(sys$dclexh(&pipe_exitblock));
2112           handler_set_up = TRUE;
2113         }
2114         _ckvmssts(sys$setast(1));
2115     }
2116
2117     /* see if we can find a VMSPIPE.COM */
2118
2119     tfilebuf[0] = '@';
2120     vmspipe = find_vmspipe(aTHX);
2121     if (vmspipe) {
2122         strcpy(tfilebuf+1,vmspipe);
2123     } else {        /* uh, oh...we're in tempfile hell */
2124         tpipe = vmspipe_tempfile(aTHX);
2125         if (!tpipe) {       /* a fish popular in Boston */
2126             if (ckWARN(WARN_PIPE)) {
2127                 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2128             }
2129         return Nullfp;
2130         }
2131         fgetname(tpipe,tfilebuf+1,1);
2132     }
2133     vmspipedsc.dsc$a_pointer = tfilebuf;
2134     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
2135
2136     sts = setup_cmddsc(aTHX_ cmd,0,0);
2137     if (!(sts & 1)) {
2138       switch (sts) {
2139         case RMS$_FNF:  case RMS$_DNF:
2140           set_errno(ENOENT); break;
2141         case RMS$_DIR:
2142           set_errno(ENOTDIR); break;
2143         case RMS$_DEV:
2144           set_errno(ENODEV); break;
2145         case RMS$_PRV:
2146           set_errno(EACCES); break;
2147         case RMS$_SYN:
2148           set_errno(EINVAL); break;
2149         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2150           set_errno(E2BIG); break;
2151         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2152           _ckvmssts(sts); /* fall through */
2153         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2154           set_errno(EVMSERR);
2155       }
2156       set_vaxc_errno(sts);
2157       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2158         Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2159       }
2160       *psts = sts;
2161       return Nullfp;
2162     }
2163     New(1301,info,1,Info);
2164
2165     strcpy(mode,in_mode);
2166     info->mode = *mode;
2167     info->done = FALSE;
2168     info->completion = 0;
2169     info->closing    = FALSE;
2170     info->in         = 0;
2171     info->out        = 0;
2172     info->err        = 0;
2173     info->fp         = Nullfp;
2174     info->useFILE    = 0;
2175     info->waiting    = 0;
2176     info->in_done    = TRUE;
2177     info->out_done   = TRUE;
2178     info->err_done   = TRUE;
2179     in[0] = out[0] = err[0] = '\0';
2180
2181     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
2182         info->useFILE = 1;
2183         strcpy(p,p+1);
2184     }
2185     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
2186         wait = 1;
2187         strcpy(p,p+1);
2188     }
2189
2190     if (*mode == 'r') {             /* piping from subroutine */
2191
2192         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2193         if (info->out) {
2194             info->out->pipe_done = &info->out_done;
2195             info->out_done = FALSE;
2196             info->out->info = info;
2197         }
2198         if (!info->useFILE) {
2199         info->fp  = PerlIO_open(mbx, mode);
2200         } else {
2201             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2202             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2203         }
2204
2205         if (!info->fp && info->out) {
2206             sys$cancel(info->out->chan_out);
2207
2208             while (!info->out_done) {
2209                 int done;
2210                 _ckvmssts(sys$setast(0));
2211                 done = info->out_done;
2212                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2213                 _ckvmssts(sys$setast(1));
2214                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2215             }
2216
2217             if (info->out->buf) Safefree(info->out->buf);
2218             Safefree(info->out);
2219             Safefree(info);
2220             *psts = RMS$_FNF;
2221             return Nullfp;
2222         }
2223
2224         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2225         if (info->err) {
2226             info->err->pipe_done = &info->err_done;
2227             info->err_done = FALSE;
2228             info->err->info = info;
2229         }
2230
2231     } else if (*mode == 'w') {      /* piping to subroutine */
2232
2233         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2234         if (info->out) {
2235             info->out->pipe_done = &info->out_done;
2236             info->out_done = FALSE;
2237             info->out->info = info;
2238         }
2239
2240         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2241         if (info->err) {
2242             info->err->pipe_done = &info->err_done;
2243             info->err_done = FALSE;
2244             info->err->info = info;
2245         }
2246
2247         info->in = pipe_tochild_setup(aTHX_ in,mbx);
2248         if (!info->useFILE) {
2249         info->fp  = PerlIO_open(mbx, mode);
2250         } else {
2251             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2252             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2253         }
2254
2255         if (info->in) {
2256             info->in->pipe_done = &info->in_done;
2257             info->in_done = FALSE;
2258             info->in->info = info;
2259         }
2260
2261         /* error cleanup */
2262         if (!info->fp && info->in) {
2263             info->done = TRUE;
2264             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2265                               0, 0, 0, 0, 0, 0, 0, 0));
2266
2267             while (!info->in_done) {
2268                 int done;
2269                 _ckvmssts(sys$setast(0));
2270                 done = info->in_done;
2271                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2272                 _ckvmssts(sys$setast(1));
2273                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2274             }
2275
2276             if (info->in->buf) Safefree(info->in->buf);
2277             Safefree(info->in);
2278             Safefree(info);
2279             *psts = RMS$_FNF;
2280             return Nullfp;
2281         }
2282
2283
2284     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
2285         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2286         if (info->out) {
2287             info->out->pipe_done = &info->out_done;
2288             info->out_done = FALSE;
2289             info->out->info = info;
2290         }
2291
2292         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2293         if (info->err) {
2294             info->err->pipe_done = &info->err_done;
2295             info->err_done = FALSE;
2296             info->err->info = info;
2297         }
2298     }
2299
2300     symbol[MAX_DCL_SYMBOL] = '\0';
2301
2302     strncpy(symbol, in, MAX_DCL_SYMBOL);
2303     d_symbol.dsc$w_length = strlen(symbol);
2304     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2305
2306     strncpy(symbol, err, MAX_DCL_SYMBOL);
2307     d_symbol.dsc$w_length = strlen(symbol);
2308     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2309
2310     strncpy(symbol, out, MAX_DCL_SYMBOL);
2311     d_symbol.dsc$w_length = strlen(symbol);
2312     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2313
2314     p = VMSCMD.dsc$a_pointer;
2315     while (*p && *p != '\n') p++;
2316     *p = '\0';                                  /* truncate on \n */
2317     p = VMSCMD.dsc$a_pointer;
2318     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
2319     if (*p == '$') p++;                         /* remove leading $ */
2320     while (*p == ' ' || *p == '\t') p++;
2321     strncpy(symbol, p, MAX_DCL_SYMBOL);
2322     d_symbol.dsc$w_length = strlen(symbol);
2323     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2324
2325     _ckvmssts(sys$setast(0));
2326     info->next=open_pipes;  /* prepend to list */
2327     open_pipes=info;
2328     _ckvmssts(sys$setast(1));
2329     _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2330                       0, &info->pid, &info->completion,
2331                       0, popen_completion_ast,info,0,0,0));
2332
2333     /* if we were using a tempfile, close it now */
2334
2335     if (tpipe) fclose(tpipe);
2336
2337     /* once the subprocess is spawned, it has copied the symbols and
2338        we can get rid of ours */
2339
2340     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2341     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
2342     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2343     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2344     vms_execfree(aTHX);
2345
2346     PL_forkprocess = info->pid;
2347     if (wait) {
2348          int done = 0;
2349          while (!done) {
2350              _ckvmssts(sys$setast(0));
2351              done = info->done;
2352              if (!done) _ckvmssts(sys$clref(pipe_ef));
2353              _ckvmssts(sys$setast(1));
2354              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2355          }
2356         *psts = info->completion;
2357         my_pclose(info->fp);
2358     } else {
2359         *psts = SS$_NORMAL;
2360     }
2361     return info->fp;
2362 }  /* end of safe_popen */
2363
2364
2365 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
2366 PerlIO *
2367 Perl_my_popen(pTHX_ char *cmd, char *mode)
2368 {
2369     int sts;
2370     TAINT_ENV();
2371     TAINT_PROPER("popen");
2372     PERL_FLUSHALL_FOR_CHILD;
2373     return safe_popen(aTHX_ cmd,mode,&sts);
2374 }
2375
2376 /*}}}*/
2377
2378 /*{{{  I32 my_pclose(PerlIO *fp)*/
2379 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2380 {
2381     pInfo info, last = NULL;
2382     unsigned long int retsts;
2383     int done, iss;
2384
2385     for (info = open_pipes; info != NULL; last = info, info = info->next)
2386         if (info->fp == fp) break;
2387
2388     if (info == NULL) {  /* no such pipe open */
2389       set_errno(ECHILD); /* quoth POSIX */
2390       set_vaxc_errno(SS$_NONEXPR);
2391       return -1;
2392     }
2393
2394     /* If we were writing to a subprocess, insure that someone reading from
2395      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
2396      * produce an EOF record in the mailbox.
2397      *
2398      *  well, at least sometimes it *does*, so we have to watch out for
2399      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
2400      */
2401      if (info->fp) {
2402         if (!info->useFILE)
2403      PerlIO_flush(info->fp);   /* first, flush data */
2404         else
2405             fflush((FILE *)info->fp);
2406     }
2407
2408     _ckvmssts(sys$setast(0));
2409      info->closing = TRUE;
2410      done = info->done && info->in_done && info->out_done && info->err_done;
2411      /* hanging on write to Perl's input? cancel it */
2412      if (info->mode == 'r' && info->out && !info->out_done) {
2413         if (info->out->chan_out) {
2414             _ckvmssts(sys$cancel(info->out->chan_out));
2415             if (!info->out->chan_in) {   /* EOF generation, need AST */
2416                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2417             }
2418         }
2419      }
2420      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
2421          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2422                            0, 0, 0, 0, 0, 0));
2423     _ckvmssts(sys$setast(1));
2424     if (info->fp) {
2425      if (!info->useFILE)
2426     PerlIO_close(info->fp);
2427      else
2428         fclose((FILE *)info->fp);
2429     }
2430      /*
2431         we have to wait until subprocess completes, but ALSO wait until all
2432         the i/o completes...otherwise we'll be freeing the "info" structure
2433         that the i/o ASTs could still be using...
2434      */
2435
2436      while (!done) {
2437          _ckvmssts(sys$setast(0));
2438          done = info->done && info->in_done && info->out_done && info->err_done;
2439          if (!done) _ckvmssts(sys$clref(pipe_ef));
2440          _ckvmssts(sys$setast(1));
2441          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2442      }
2443      retsts = info->completion;
2444
2445     /* remove from list of open pipes */
2446     _ckvmssts(sys$setast(0));
2447     if (last) last->next = info->next;
2448     else open_pipes = info->next;
2449     _ckvmssts(sys$setast(1));
2450
2451     /* free buffers and structures */
2452
2453     if (info->in) {
2454         if (info->in->buf) Safefree(info->in->buf);
2455         Safefree(info->in);
2456     }
2457     if (info->out) {
2458         if (info->out->buf) Safefree(info->out->buf);
2459         Safefree(info->out);
2460     }
2461     if (info->err) {
2462         if (info->err->buf) Safefree(info->err->buf);
2463         Safefree(info->err);
2464     }
2465     Safefree(info);
2466
2467     return retsts;
2468
2469 }  /* end of my_pclose() */
2470
2471 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2472   /* Roll our own prototype because we want this regardless of whether
2473    * _VMS_WAIT is defined.
2474    */
2475   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2476 #endif
2477 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2478    created with popen(); otherwise partially emulate waitpid() unless
2479    we have a suitable one from the CRTL that came with VMS 7.2 and later.
2480    Also check processes not considered by the CRTL waitpid().
2481  */
2482 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2483 Pid_t
2484 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2485 {
2486     pInfo info;
2487     int done;
2488     int sts;
2489
2490     if (statusp) *statusp = 0;
2491
2492     for (info = open_pipes; info != NULL; info = info->next)
2493         if (info->pid == pid) break;
2494
2495     if (info != NULL) {  /* we know about this child */
2496       while (!info->done) {
2497           _ckvmssts(sys$setast(0));
2498           done = info->done;
2499           if (!done) _ckvmssts(sys$clref(pipe_ef));
2500           _ckvmssts(sys$setast(1));
2501           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2502       }
2503
2504       if (statusp) *statusp = info->completion;
2505       return pid;
2506
2507     }
2508     else {  /* this child is not one of our own pipe children */
2509
2510 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2511
2512       /* waitpid() became available in the CRTL as of VMS 7.0, but only
2513        * in 7.2 did we get a version that fills in the VMS completion
2514        * status as Perl has always tried to do.
2515        */
2516
2517       sts = __vms_waitpid( pid, statusp, flags );
2518
2519       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2520          return sts;
2521
2522       /* If the real waitpid tells us the child does not exist, we
2523        * fall through here to implement waiting for a child that
2524        * was created by some means other than exec() (say, spawned
2525        * from DCL) or to wait for a process that is not a subprocess
2526        * of the current process.
2527        */
2528
2529 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2530
2531       $DESCRIPTOR(intdsc,"0 00:00:01");
2532       unsigned long int ownercode = JPI$_OWNER, ownerpid;
2533       unsigned long int pidcode = JPI$_PID, mypid;
2534       unsigned long int interval[2];
2535       int termination_mbu = 0;
2536       unsigned short qio_iosb[4];
2537       unsigned int jpi_iosb[2];
2538       struct itmlst_3 jpilist[3] = {
2539           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
2540           {sizeof(termination_mbu), JPI$_TMBU,  &termination_mbu, 0},
2541           {                      0,         0,                 0, 0}
2542       };
2543       char trmmbx[NAM$C_DVI+1];
2544       $DESCRIPTOR(trmmbxdsc,trmmbx);
2545       struct accdef trmmsg;
2546       unsigned short int mbxchan;
2547
2548       if (pid <= 0) {
2549         /* Sorry folks, we don't presently implement rooting around for
2550            the first child we can find, and we definitely don't want to
2551            pass a pid of -1 to $getjpi, where it is a wildcard operation.
2552          */
2553         set_errno(ENOTSUP);
2554         return -1;
2555       }
2556
2557       /* Get the owner of the child so I can warn if it's not mine, plus
2558        * get the termination mailbox.  If the process doesn't exist or I
2559        * don't have the privs to look at it, I can go home early.
2560        */
2561       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2562       if (sts & 1) sts = jpi_iosb[0];
2563       if (!(sts & 1)) {
2564         switch (sts) {
2565             case SS$_NONEXPR:
2566                 set_errno(ECHILD);
2567                 break;
2568             case SS$_NOPRIV:
2569                 set_errno(EACCES);
2570                 break;
2571             default:
2572                 _ckvmssts(sts);
2573         }
2574         set_vaxc_errno(sts);
2575         return -1;
2576       }
2577
2578       if (ckWARN(WARN_EXEC)) {
2579         /* remind folks they are asking for non-standard waitpid behavior */
2580         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2581         if (ownerpid != mypid)
2582           Perl_warner(aTHX_ WARN_EXEC,
2583                       "waitpid: process %x is not a child of process %x",
2584                       pid,mypid);
2585       }
2586
2587       /* It's possible to have a mailbox unit number but no actual mailbox; we
2588        * check for this by assigning a channel to it, which we need anyway.
2589        */
2590       if (termination_mbu != 0) {
2591           sprintf(trmmbx, "MBA%d:", termination_mbu);
2592           trmmbxdsc.dsc$w_length = strlen(trmmbx);
2593           sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
2594           if (sts == SS$_NOSUCHDEV) {
2595               termination_mbu = 0; /* set up to take "no mailbox" case */
2596               sts = SS$_NORMAL;
2597           }
2598           _ckvmssts(sts);
2599       }
2600       /* If the process doesn't have a termination mailbox, then simply check
2601        * on it once a second until it's not there anymore.
2602        */
2603       if (termination_mbu == 0) {
2604           _ckvmssts(sys$bintim(&intdsc,interval));
2605           while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2606             _ckvmssts(sys$schdwk(0,0,interval,0));
2607             _ckvmssts(sys$hiber());
2608           }
2609           if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2610       }
2611       else {
2612         /* If we do have a termination mailbox, post reads to it until we get a
2613          * termination message, discarding messages of the wrong type or for other
2614          * processes.  If there is a place to put the final status, then do so.
2615          */
2616           sts = SS$_NORMAL;
2617           while (sts & 1) {
2618               memset((void *) &trmmsg, 0, sizeof(trmmsg));
2619               sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
2620                              &trmmsg,ACC$K_TERMLEN,0,0,0,0);
2621               if (sts & 1) sts = qio_iosb[0];
2622
2623               if ( sts & 1
2624                    && trmmsg.acc$w_msgtyp == MSG$_DELPROC
2625                    && trmmsg.acc$l_pid == pid ) {
2626
2627                   if (statusp) *statusp = trmmsg.acc$l_finalsts;
2628                   sts = sys$dassgn(mbxchan);
2629                   break;
2630               }
2631           }
2632       } /* termination_mbu ? */
2633
2634       _ckvmssts(sts);
2635       return pid;
2636
2637     } /* else one of our own pipe children */
2638
2639 }  /* end of waitpid() */
2640 /*}}}*/
2641 /*}}}*/
2642 /*}}}*/
2643
2644 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2645 char *
2646 my_gconvert(double val, int ndig, int trail, char *buf)
2647 {
2648   static char __gcvtbuf[DBL_DIG+1];
2649   char *loc;
2650
2651   loc = buf ? buf : __gcvtbuf;
2652
2653 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
2654   if (val < 1) {
2655     sprintf(loc,"%.*g",ndig,val);
2656     return loc;
2657   }
2658 #endif
2659
2660   if (val) {
2661     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2662     return gcvt(val,ndig,loc);
2663   }
2664   else {
2665     loc[0] = '0'; loc[1] = '\0';
2666     return loc;
2667   }
2668
2669 }
2670 /*}}}*/
2671
2672
2673 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2674 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2675  * to expand file specification.  Allows for a single default file
2676  * specification and a simple mask of options.  If outbuf is non-NULL,
2677  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2678  * the resultant file specification is placed.  If outbuf is NULL, the
2679  * resultant file specification is placed into a static buffer.
2680  * The third argument, if non-NULL, is taken to be a default file
2681  * specification string.  The fourth argument is unused at present.
2682  * rmesexpand() returns the address of the resultant string if
2683  * successful, and NULL on error.
2684  */
2685 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2686
2687 static char *
2688 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2689 {
2690   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2691   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2692   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2693   struct FAB myfab = cc$rms_fab;
2694   struct NAM mynam = cc$rms_nam;
2695   STRLEN speclen;
2696   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2697
2698   if (!filespec || !*filespec) {
2699     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2700     return NULL;
2701   }
2702   if (!outbuf) {
2703     if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2704     else    outbuf = __rmsexpand_retbuf;
2705   }
2706   if ((isunix = (strchr(filespec,'/') != NULL))) {
2707     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2708     filespec = vmsfspec;
2709   }
2710
2711   myfab.fab$l_fna = filespec;
2712   myfab.fab$b_fns = strlen(filespec);
2713   myfab.fab$l_nam = &mynam;
2714
2715   if (defspec && *defspec) {
2716     if (strchr(defspec,'/') != NULL) {
2717       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2718       defspec = tmpfspec;
2719     }
2720     myfab.fab$l_dna = defspec;
2721     myfab.fab$b_dns = strlen(defspec);
2722   }
2723
2724   mynam.nam$l_esa = esa;
2725   mynam.nam$b_ess = sizeof esa;
2726   mynam.nam$l_rsa = outbuf;
2727   mynam.nam$b_rss = NAM$C_MAXRSS;
2728
2729   retsts = sys$parse(&myfab,0,0);
2730   if (!(retsts & 1)) {
2731     mynam.nam$b_nop |= NAM$M_SYNCHK;
2732     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2733       retsts = sys$parse(&myfab,0,0);
2734       if (retsts & 1) goto expanded;
2735     }
2736     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2737     (void) sys$parse(&myfab,0,0);  /* Free search context */
2738     if (out) Safefree(out);
2739     set_vaxc_errno(retsts);
2740     if      (retsts == RMS$_PRV) set_errno(EACCES);
2741     else if (retsts == RMS$_DEV) set_errno(ENODEV);
2742     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2743     else                         set_errno(EVMSERR);
2744     return NULL;
2745   }
2746   retsts = sys$search(&myfab,0,0);
2747   if (!(retsts & 1) && retsts != RMS$_FNF) {
2748     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2749     myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
2750     if (out) Safefree(out);
2751     set_vaxc_errno(retsts);
2752     if      (retsts == RMS$_PRV) set_errno(EACCES);
2753     else                         set_errno(EVMSERR);
2754     return NULL;
2755   }
2756
2757   /* If the input filespec contained any lowercase characters,
2758    * downcase the result for compatibility with Unix-minded code. */
2759   expanded:
2760   for (out = myfab.fab$l_fna; *out; out++)
2761     if (islower(*out)) { haslower = 1; break; }
2762   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2763   else                 { out = esa;    speclen = mynam.nam$b_esl; }
2764   /* Trim off null fields added by $PARSE
2765    * If type > 1 char, must have been specified in original or default spec
2766    * (not true for version; $SEARCH may have added version of existing file).
2767    */
2768   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2769   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2770              (mynam.nam$l_ver - mynam.nam$l_type == 1);
2771   if (trimver || trimtype) {
2772     if (defspec && *defspec) {
2773       char defesa[NAM$C_MAXRSS];
2774       struct FAB deffab = cc$rms_fab;
2775       struct NAM defnam = cc$rms_nam;
2776
2777       deffab.fab$l_nam = &defnam;
2778       deffab.fab$l_fna = defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
2779       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
2780       defnam.nam$b_nop = NAM$M_SYNCHK;
2781       if (sys$parse(&deffab,0,0) & 1) {
2782         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2783         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2784       }
2785     }
2786     if (trimver) speclen = mynam.nam$l_ver - out;
2787     if (trimtype) {
2788       /* If we didn't already trim version, copy down */
2789       if (speclen > mynam.nam$l_ver - out)
2790         memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2791                speclen - (mynam.nam$l_ver - out));
2792       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2793     }
2794   }
2795   /* If we just had a directory spec on input, $PARSE "helpfully"
2796    * adds an empty name and type for us */
2797   if (mynam.nam$l_name == mynam.nam$l_type &&
2798       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
2799       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2800     speclen = mynam.nam$l_name - out;
2801   out[speclen] = '\0';
2802   if (haslower) __mystrtolower(out);
2803
2804   /* Have we been working with an expanded, but not resultant, spec? */
2805   /* Also, convert back to Unix syntax if necessary. */
2806   if (!mynam.nam$b_rsl) {
2807     if (isunix) {
2808       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2809     }
2810     else strcpy(outbuf,esa);
2811   }
2812   else if (isunix) {
2813     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2814     strcpy(outbuf,tmpfspec);
2815   }
2816   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2817   mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2818   myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
2819   return outbuf;
2820 }
2821 /*}}}*/
2822 /* External entry points */
2823 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2824 { return do_rmsexpand(spec,buf,0,def,opt); }
2825 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2826 { return do_rmsexpand(spec,buf,1,def,opt); }
2827
2828
2829 /*
2830 ** The following routines are provided to make life easier when
2831 ** converting among VMS-style and Unix-style directory specifications.
2832 ** All will take input specifications in either VMS or Unix syntax. On
2833 ** failure, all return NULL.  If successful, the routines listed below
2834 ** return a pointer to a buffer containing the appropriately
2835 ** reformatted spec (and, therefore, subsequent calls to that routine
2836 ** will clobber the result), while the routines of the same names with
2837 ** a _ts suffix appended will return a pointer to a mallocd string
2838 ** containing the appropriately reformatted spec.
2839 ** In all cases, only explicit syntax is altered; no check is made that
2840 ** the resulting string is valid or that the directory in question
2841 ** actually exists.
2842 **
2843 **   fileify_dirspec() - convert a directory spec into the name of the
2844 **     directory file (i.e. what you can stat() to see if it's a dir).
2845 **     The style (VMS or Unix) of the result is the same as the style
2846 **     of the parameter passed in.
2847 **   pathify_dirspec() - convert a directory spec into a path (i.e.
2848 **     what you prepend to a filename to indicate what directory it's in).
2849 **     The style (VMS or Unix) of the result is the same as the style
2850 **     of the parameter passed in.
2851 **   tounixpath() - convert a directory spec into a Unix-style path.
2852 **   tovmspath() - convert a directory spec into a VMS-style path.
2853 **   tounixspec() - convert any file spec into a Unix-style file spec.
2854 **   tovmsspec() - convert any file spec into a VMS-style spec.
2855 **
2856 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
2857 ** Permission is given to distribute this code as part of the Perl
2858 ** standard distribution under the terms of the GNU General Public
2859 ** License or the Perl Artistic License.  Copies of each may be
2860 ** found in the Perl standard distribution.
2861  */
2862
2863 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2864 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2865 {
2866     static char __fileify_retbuf[NAM$C_MAXRSS+1];
2867     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2868     char *retspec, *cp1, *cp2, *lastdir;
2869     char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2870
2871     if (!dir || !*dir) {
2872       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2873     }
2874     dirlen = strlen(dir);
2875     while (dirlen && dir[dirlen-1] == '/') --dirlen;
2876     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2877       strcpy(trndir,"/sys$disk/000000");
2878       dir = trndir;
2879       dirlen = 16;
2880     }
2881     if (dirlen > NAM$C_MAXRSS) {
2882       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2883     }
2884     if (!strpbrk(dir+1,"/]>:")) {
2885       strcpy(trndir,*dir == '/' ? dir + 1: dir);
2886       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2887       dir = trndir;
2888       dirlen = strlen(dir);
2889     }
2890     else {
2891       strncpy(trndir,dir,dirlen);
2892       trndir[dirlen] = '\0';
2893       dir = trndir;
2894     }
2895     /* If we were handed a rooted logical name or spec, treat it like a
2896      * simple directory, so that
2897      *    $ Define myroot dev:[dir.]
2898      *    ... do_fileify_dirspec("myroot",buf,1) ...
2899      * does something useful.
2900      */
2901     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2902       dir[--dirlen] = '\0';
2903       dir[dirlen-1] = ']';
2904     }
2905     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
2906       dir[--dirlen] = '\0';
2907       dir[dirlen-1] = '>';
2908     }
2909
2910     if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2911       /* If we've got an explicit filename, we can just shuffle the string. */
2912       if (*(cp1+1)) hasfilename = 1;
2913       /* Similarly, we can just back up a level if we've got multiple levels
2914          of explicit directories in a VMS spec which ends with directories. */
2915       else {
2916         for (cp2 = cp1; cp2 > dir; cp2--) {
2917           if (*cp2 == '.') {
2918             *cp2 = *cp1; *cp1 = '\0';
2919             hasfilename = 1;
2920             break;
2921           }
2922           if (*cp2 == '[' || *cp2 == '<') break;
2923         }
2924       }
2925     }
2926
2927     if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2928       if (dir[0] == '.') {
2929         if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2930           return do_fileify_dirspec("[]",buf,ts);
2931         else if (dir[1] == '.' &&
2932                  (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2933           return do_fileify_dirspec("[-]",buf,ts);
2934       }
2935       if (dirlen && dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
2936         dirlen -= 1;                 /* to last element */
2937         lastdir = strrchr(dir,'/');
2938       }
2939       else if ((cp1 = strstr(dir,"/.")) != NULL) {
2940         /* If we have "/." or "/..", VMSify it and let the VMS code
2941          * below expand it, rather than repeating the code to handle
2942          * relative components of a filespec here */
2943         do {
2944           if (*(cp1+2) == '.') cp1++;
2945           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2946             if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2947             if (strchr(vmsdir,'/') != NULL) {
2948               /* If do_tovmsspec() returned it, it must have VMS syntax
2949                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
2950                * the time to check this here only so we avoid a recursion
2951                * loop; otherwise, gigo.
2952                */
2953               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
2954             }
2955             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2956             return do_tounixspec(trndir,buf,ts);
2957           }
2958           cp1++;
2959         } while ((cp1 = strstr(cp1,"/.")) != NULL);
2960         lastdir = strrchr(dir,'/');
2961       }
2962       else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2963         /* Ditto for specs that end in an MFD -- let the VMS code
2964          * figure out whether it's a real device or a rooted logical. */
2965         dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2966         if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2967         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2968         return do_tounixspec(trndir,buf,ts);
2969       }
2970       else {
2971         if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2972              !(lastdir = cp1 = strrchr(dir,']')) &&
2973              !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2974         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
2975           int ver; char *cp3;
2976           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
2977               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
2978               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2979               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
2980               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2981                             (ver || *cp3)))))) {
2982             set_errno(ENOTDIR);
2983             set_vaxc_errno(RMS$_DIR);
2984             return NULL;
2985           }
2986           dirlen = cp2 - dir;
2987         }
2988       }
2989       /* If we lead off with a device or rooted logical, add the MFD
2990          if we're specifying a top-level directory. */
2991       if (lastdir && *dir == '/') {
2992         addmfd = 1;
2993         for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2994           if (*cp1 == '/') {
2995             addmfd = 0;
2996             break;
2997           }
2998         }
2999       }
3000       retlen = dirlen + (addmfd ? 13 : 6);
3001       if (buf) retspec = buf;
3002       else if (ts) New(1309,retspec,retlen+1,char);
3003       else retspec = __fileify_retbuf;
3004       if (addmfd) {
3005         dirlen = lastdir - dir;
3006         memcpy(retspec,dir,dirlen);
3007         strcpy(&retspec[dirlen],"/000000");
3008         strcpy(&retspec[dirlen+7],lastdir);
3009       }
3010       else {
3011         memcpy(retspec,dir,dirlen);
3012         retspec[dirlen] = '\0';
3013       }
3014       /* We've picked up everything up to the directory file name.
3015          Now just add the type and version, and we're set. */
3016       strcat(retspec,".dir;1");
3017       return retspec;
3018     }
3019     else {  /* VMS-style directory spec */
3020       char esa[NAM$C_MAXRSS+1], term, *cp;
3021       unsigned long int sts, cmplen, haslower = 0;
3022       struct FAB dirfab = cc$rms_fab;
3023       struct NAM savnam, dirnam = cc$rms_nam;
3024
3025       dirfab.fab$b_fns = strlen(dir);
3026       dirfab.fab$l_fna = dir;
3027       dirfab.fab$l_nam = &dirnam;
3028       dirfab.fab$l_dna = ".DIR;1";
3029       dirfab.fab$b_dns = 6;
3030       dirnam.nam$b_ess = NAM$C_MAXRSS;
3031       dirnam.nam$l_esa = esa;
3032
3033       for (cp = dir; *cp; cp++)
3034         if (islower(*cp)) { haslower = 1; break; }
3035       if (!((sts = sys$parse(&dirfab))&1)) {
3036         if (dirfab.fab$l_sts == RMS$_DIR) {
3037           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3038           sts = sys$parse(&dirfab) & 1;
3039         }
3040         if (!sts) {
3041           set_errno(EVMSERR);
3042           set_vaxc_errno(dirfab.fab$l_sts);
3043           return NULL;
3044         }
3045       }
3046       else {
3047         savnam = dirnam;
3048         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
3049           /* Yes; fake the fnb bits so we'll check type below */
3050           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3051         }
3052         else { /* No; just work with potential name */
3053           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3054           else {
3055             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
3056             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3057             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3058             return NULL;
3059           }
3060         }
3061       }
3062       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3063         cp1 = strchr(esa,']');
3064         if (!cp1) cp1 = strchr(esa,'>');
3065         if (cp1) {  /* Should always be true */
3066           dirnam.nam$b_esl -= cp1 - esa - 1;
3067           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3068         }
3069       }
3070       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3071         /* Yep; check version while we're at it, if it's there. */
3072         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3073         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3074           /* Something other than .DIR[;1].  Bzzt. */
3075           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3076           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3077           set_errno(ENOTDIR);
3078           set_vaxc_errno(RMS$_DIR);
3079           return NULL;
3080         }
3081       }
3082       esa[dirnam.nam$b_esl] = '\0';
3083       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3084         /* They provided at least the name; we added the type, if necessary, */
3085         if (buf) retspec = buf;                            /* in sys$parse() */
3086         else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3087         else retspec = __fileify_retbuf;
3088         strcpy(retspec,esa);
3089         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3090         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3091         return retspec;
3092       }
3093       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3094         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3095         *cp1 = '\0';
3096         dirnam.nam$b_esl -= 9;
3097       }
3098       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3099       if (cp1 == NULL) { /* should never happen */
3100         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3101         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3102         return NULL;
3103       }
3104       term = *cp1;
3105       *cp1 = '\0';
3106       retlen = strlen(esa);
3107       if ((cp1 = strrchr(esa,'.')) != NULL) {
3108         /* There's more than one directory in the path.  Just roll back. */
3109         *cp1 = term;
3110         if (buf) retspec = buf;
3111         else if (ts) New(1311,retspec,retlen+7,char);
3112         else retspec = __fileify_retbuf;
3113         strcpy(retspec,esa);
3114       }
3115       else {
3116         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3117           /* Go back and expand rooted logical name */
3118           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3119           if (!(sys$parse(&dirfab) & 1)) {
3120             dirnam.nam$l_rlf = NULL;
3121             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3122             set_errno(EVMSERR);
3123             set_vaxc_errno(dirfab.fab$l_sts);
3124             return NULL;
3125           }
3126           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3127           if (buf) retspec = buf;
3128           else if (ts) New(1312,retspec,retlen+16,char);
3129           else retspec = __fileify_retbuf;
3130           cp1 = strstr(esa,"][");
3131           if (!cp1) cp1 = strstr(esa,"]<");
3132           dirlen = cp1 - esa;
3133           memcpy(retspec,esa,dirlen);
3134           if (!strncmp(cp1+2,"000000]",7)) {
3135             retspec[dirlen-1] = '\0';
3136             for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3137             if (*cp1 == '.') *cp1 = ']';
3138             else {
3139               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3140               memcpy(cp1+1,"000000]",7);
3141             }
3142           }
3143           else {
3144             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3145             retspec[retlen] = '\0';
3146             /* Convert last '.' to ']' */
3147             for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3148             if (*cp1 == '.') *cp1 = ']';
3149             else {
3150               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3151               memcpy(cp1+1,"000000]",7);
3152             }
3153           }
3154         }
3155         else {  /* This is a top-level dir.  Add the MFD to the path. */
3156           if (buf) retspec = buf;
3157           else if (ts) New(1312,retspec,retlen+16,char);
3158           else retspec = __fileify_retbuf;
3159           cp1 = esa;
3160           cp2 = retspec;
3161           while (*cp1 != ':') *(cp2++) = *(cp1++);
3162           strcpy(cp2,":[000000]");
3163           cp1 += 2;
3164           strcpy(cp2+9,cp1);
3165         }
3166       }
3167       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3168       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3169       /* We've set up the string up through the filename.  Add the
3170          type and version, and we're done. */
3171       strcat(retspec,".DIR;1");
3172
3173       /* $PARSE may have upcased filespec, so convert output to lower
3174        * case if input contained any lowercase characters. */
3175       if (haslower) __mystrtolower(retspec);
3176       return retspec;
3177     }
3178 }  /* end of do_fileify_dirspec() */
3179 /*}}}*/
3180 /* External entry points */
3181 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3182 { return do_fileify_dirspec(dir,buf,0); }
3183 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3184 { return do_fileify_dirspec(dir,buf,1); }
3185
3186 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3187 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3188 {
3189     static char __pathify_retbuf[NAM$C_MAXRSS+1];
3190     unsigned long int retlen;
3191     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3192
3193     if (!dir || !*dir) {
3194       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3195     }
3196
3197     if (*dir) strcpy(trndir,dir);
3198     else getcwd(trndir,sizeof trndir - 1);
3199
3200     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3201            && my_trnlnm(trndir,trndir,0)) {
3202       STRLEN trnlen = strlen(trndir);
3203
3204       /* Trap simple rooted lnms, and return lnm:[000000] */
3205       if (!strcmp(trndir+trnlen-2,".]")) {
3206         if (buf) retpath = buf;
3207         else if (ts) New(1318,retpath,strlen(dir)+10,char);
3208         else retpath = __pathify_retbuf;
3209         strcpy(retpath,dir);
3210         strcat(retpath,":[000000]");
3211         return retpath;
3212       }
3213     }
3214     dir = trndir;
3215
3216     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3217       if (*dir == '.' && (*(dir+1) == '\0' ||
3218                           (*(dir+1) == '.' && *(dir+2) == '\0')))
3219         retlen = 2 + (*(dir+1) != '\0');
3220       else {
3221         if ( !(cp1 = strrchr(dir,'/')) &&
3222              !(cp1 = strrchr(dir,']')) &&
3223              !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3224         if ((cp2 = strchr(cp1,'.')) != NULL &&
3225             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
3226              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
3227               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3228               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3229           int ver; char *cp3;
3230           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3231               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3232               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3233               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3234               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3235                             (ver || *cp3)))))) {
3236             set_errno(ENOTDIR);
3237             set_vaxc_errno(RMS$_DIR);
3238             return NULL;
3239           }
3240           retlen = cp2 - dir + 1;
3241         }
3242         else {  /* No file type present.  Treat the filename as a directory. */
3243           retlen = strlen(dir) + 1;
3244         }
3245       }
3246       if (buf) retpath = buf;
3247       else if (ts) New(1313,retpath,retlen+1,char);
3248       else retpath = __pathify_retbuf;
3249       strncpy(retpath,dir,retlen-1);
3250       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3251         retpath[retlen-1] = '/';      /* with '/', add it. */
3252         retpath[retlen] = '\0';
3253       }
3254       else retpath[retlen-1] = '\0';
3255     }
3256     else {  /* VMS-style directory spec */
3257       char esa[NAM$C_MAXRSS+1], *cp;
3258       unsigned long int sts, cmplen, haslower;
3259       struct FAB dirfab = cc$rms_fab;
3260       struct NAM savnam, dirnam = cc$rms_nam;
3261
3262       /* If we've got an explicit filename, we can just shuffle the string. */
3263       if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3264              (cp1 = strrchr(dir,'>')) != NULL     ) && *(cp1+1)) {
3265         if ((cp2 = strchr(cp1,'.')) != NULL) {
3266           int ver; char *cp3;
3267           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3268               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3269               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3270               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3271               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3272                             (ver || *cp3)))))) {
3273             set_errno(ENOTDIR);
3274             set_vaxc_errno(RMS$_DIR);
3275             return NULL;
3276           }
3277         }
3278         else {  /* No file type, so just draw name into directory part */
3279           for (cp2 = cp1; *cp2; cp2++) ;
3280         }
3281         *cp2 = *cp1;
3282         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
3283         *cp1 = '.';
3284         /* We've now got a VMS 'path'; fall through */
3285       }
3286       dirfab.fab$b_fns = strlen(dir);
3287       dirfab.fab$l_fna = dir;
3288       if (dir[dirfab.fab$b_fns-1] == ']' ||
3289           dir[dirfab.fab$b_fns-1] == '>' ||
3290           dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3291         if (buf) retpath = buf;
3292         else if (ts) New(1314,retpath,strlen(dir)+1,char);
3293         else retpath = __pathify_retbuf;
3294         strcpy(retpath,dir);
3295         return retpath;
3296       }
3297       dirfab.fab$l_dna = ".DIR;1";
3298       dirfab.fab$b_dns = 6;
3299       dirfab.fab$l_nam = &dirnam;
3300       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3301       dirnam.nam$l_esa = esa;
3302
3303       for (cp = dir; *cp; cp++)
3304         if (islower(*cp)) { haslower = 1; break; }
3305
3306       if (!(sts = (sys$parse(&dirfab)&1))) {
3307         if (dirfab.fab$l_sts == RMS$_DIR) {
3308           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3309           sts = sys$parse(&dirfab) & 1;
3310         }
3311         if (!sts) {
3312           set_errno(EVMSERR);
3313           set_vaxc_errno(dirfab.fab$l_sts);
3314           return NULL;
3315         }
3316       }
3317       else {
3318         savnam = dirnam;
3319         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
3320           if (dirfab.fab$l_sts != RMS$_FNF) {
3321             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3322             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3323             set_errno(EVMSERR);
3324             set_vaxc_errno(dirfab.fab$l_sts);
3325             return NULL;
3326           }
3327           dirnam = savnam; /* No; just work with potential name */
3328         }
3329       }
3330       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3331         /* Yep; check version while we're at it, if it's there. */
3332         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3333         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3334           /* Something other than .DIR[;1].  Bzzt. */
3335           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3336           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3337           set_errno(ENOTDIR);
3338           set_vaxc_errno(RMS$_DIR);
3339           return NULL;
3340         }
3341       }
3342       /* OK, the type was fine.  Now pull any file name into the
3343          directory path. */
3344       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3345       else {
3346         cp1 = strrchr(esa,'>');
3347         *dirnam.nam$l_type = '>';
3348       }
3349       *cp1 = '.';
3350       *(dirnam.nam$l_type + 1) = '\0';
3351       retlen = dirnam.nam$l_type - esa + 2;
3352       if (buf) retpath = buf;
3353       else if (ts) New(1314,retpath,retlen,char);
3354       else retpath = __pathify_retbuf;
3355       strcpy(retpath,esa);
3356       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3357       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3358       /* $PARSE may have upcased filespec, so convert output to lower
3359        * case if input contained any lowercase characters. */
3360       if (haslower) __mystrtolower(retpath);
3361     }
3362
3363     return retpath;
3364 }  /* end of do_pathify_dirspec() */
3365 /*}}}*/
3366 /* External entry points */
3367 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3368 { return do_pathify_dirspec(dir,buf,0); }
3369 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3370 { return do_pathify_dirspec(dir,buf,1); }
3371
3372 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3373 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3374 {
3375   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3376   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3377   int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3378
3379   if (spec == NULL) return NULL;
3380   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3381   if (buf) rslt = buf;
3382   else if (ts) {
3383     retlen = strlen(spec);
3384     cp1 = strchr(spec,'[');
3385     if (!cp1) cp1 = strchr(spec,'<');
3386     if (cp1) {
3387       for (cp1++; *cp1; cp1++) {
3388         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
3389         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3390           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3391       }
3392     }
3393     New(1315,rslt,retlen+2+2*expand,char);
3394   }
3395   else rslt = __tounixspec_retbuf;
3396   if (strchr(spec,'/') != NULL) {
3397     strcpy(rslt,spec);
3398     return rslt;
3399   }
3400
3401   cp1 = rslt;
3402   cp2 = spec;
3403   dirend = strrchr(spec,']');
3404   if (dirend == NULL) dirend = strrchr(spec,'>');
3405   if (dirend == NULL) dirend = strchr(spec,':');
3406   if (dirend == NULL) {
3407     strcpy(rslt,spec);
3408     return rslt;
3409   }
3410   if (*cp2 != '[' && *cp2 != '<') {
3411     *(cp1++) = '/';
3412   }
3413   else {  /* the VMS spec begins with directories */
3414     cp2++;
3415     if (*cp2 == ']' || *cp2 == '>') {
3416       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3417       return rslt;
3418     }
3419     else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3420       if (getcwd(tmp,sizeof tmp,1) == NULL) {
3421         if (ts) Safefree(rslt);
3422         return NULL;
3423       }
3424       do {
3425         cp3 = tmp;
3426         while (*cp3 != ':' && *cp3) cp3++;
3427         *(cp3++) = '\0';
3428         if (strchr(cp3,']') != NULL) break;
3429       } while (vmstrnenv(tmp,tmp,0,fildev,0));
3430       if (ts && !buf &&
3431           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3432         retlen = devlen + dirlen;
3433         Renew(rslt,retlen+1+2*expand,char);
3434         cp1 = rslt;
3435       }
3436       cp3 = tmp;
3437       *(cp1++) = '/';
3438       while (*cp3) {
3439         *(cp1++) = *(cp3++);
3440         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3441       }
3442       *(cp1++) = '/';
3443     }
3444     else if ( *cp2 == '.') {
3445       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3446         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3447         cp2 += 3;
3448       }
3449       else cp2++;
3450     }
3451   }
3452   for (; cp2 <= dirend; cp2++) {
3453     if (*cp2 == ':') {
3454       *(cp1++) = '/';
3455       if (*(cp2+1) == '[') cp2++;
3456     }
3457     else if (*cp2 == ']' || *cp2 == '>') {
3458       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3459     }
3460     else if (*cp2 == '.') {
3461       *(cp1++) = '/';
3462       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3463         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3464                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3465         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3466             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3467       }
3468       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3469         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3470         cp2 += 2;
3471       }
3472     }
3473     else if (*cp2 == '-') {
3474       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3475         while (*cp2 == '-') {
3476           cp2++;
3477           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3478         }
3479         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3480           if (ts) Safefree(rslt);                        /* filespecs like */
3481           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
3482           return NULL;
3483         }
3484       }
3485       else *(cp1++) = *cp2;
3486     }
3487     else *(cp1++) = *cp2;
3488   }
3489   while (*cp2) *(cp1++) = *(cp2++);
3490   *cp1 = '\0';
3491
3492   return rslt;
3493
3494 }  /* end of do_tounixspec() */
3495 /*}}}*/
3496 /* External entry points */
3497 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3498 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3499
3500 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3501 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3502   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3503   char *rslt, *dirend;
3504   register char *cp1, *cp2;
3505   unsigned long int infront = 0, hasdir = 1;
3506
3507   if (path == NULL) return NULL;
3508   if (buf) rslt = buf;
3509   else if (ts) New(1316,rslt,strlen(path)+9,char);
3510   else rslt = __tovmsspec_retbuf;
3511   if (strpbrk(path,"]:>") ||
3512       (dirend = strrchr(path,'/')) == NULL) {
3513     if (path[0] == '.') {
3514       if (path[1] == '\0') strcpy(rslt,"[]");
3515       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3516       else strcpy(rslt,path); /* probably garbage */
3517     }
3518     else strcpy(rslt,path);
3519     return rslt;
3520   }
3521   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
3522     if (!*(dirend+2)) dirend +=2;
3523     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3524     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3525   }
3526   cp1 = rslt;
3527   cp2 = path;
3528   if (*cp2 == '/') {
3529     char trndev[NAM$C_MAXRSS+1];
3530     int islnm, rooted;
3531     STRLEN trnend;
3532
3533     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
3534     if (!*(cp2+1)) {
3535       if (!buf & ts) Renew(rslt,18,char);
3536       strcpy(rslt,"sys$disk:[000000]");
3537       return rslt;
3538     }
3539     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3540     *cp1 = '\0';
3541     islnm =  my_trnlnm(rslt,trndev,0);
3542     trnend = islnm ? strlen(trndev) - 1 : 0;
3543     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3544     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3545     /* If the first element of the path is a logical name, determine
3546      * whether it has to be translated so we can add more directories. */
3547     if (!islnm || rooted) {
3548       *(cp1++) = ':';
3549       *(cp1++) = '[';
3550       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3551       else cp2++;
3552     }
3553     else {
3554       if (cp2 != dirend) {
3555         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3556         strcpy(rslt,trndev);
3557         cp1 = rslt + trnend;
3558         *(cp1++) = '.';
3559         cp2++;
3560       }
3561       else {
3562         *(cp1++) = ':';
3563         hasdir = 0;
3564       }
3565     }
3566   }
3567   else {
3568     *(cp1++) = '[';
3569     if (*cp2 == '.') {
3570       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3571         cp2 += 2;         /* skip over "./" - it's redundant */
3572         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
3573       }
3574       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3575         *(cp1++) = '-';                                 /* "../" --> "-" */
3576         cp2 += 3;
3577       }
3578       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3579                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3580         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3581         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3582         cp2 += 4;
3583       }
3584       if (cp2 > dirend) cp2 = dirend;
3585     }
3586     else *(cp1++) = '.';
3587   }
3588   for (; cp2 < dirend; cp2++) {
3589     if (*cp2 == '/') {
3590       if (*(cp2-1) == '/') continue;
3591       if (*(cp1-1) != '.') *(cp1++) = '.';
3592       infront = 0;
3593     }
3594     else if (!infront && *cp2 == '.') {
3595       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3596       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
3597       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3598         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3599         else if (*(cp1-2) == '[') *(cp1-1) = '-';
3600         else {  /* back up over previous directory name */
3601           cp1--;
3602           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3603           if (*(cp1-1) == '[') {
3604             memcpy(cp1,"000000.",7);
3605             cp1 += 7;
3606           }
3607         }
3608         cp2 += 2;
3609         if (cp2 == dirend) break;
3610       }
3611       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3612                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3613         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3614         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3615         if (!*(cp2+3)) {
3616           *(cp1++) = '.';  /* Simulate trailing '/' */
3617           cp2 += 2;  /* for loop will incr this to == dirend */
3618         }
3619         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
3620       }
3621       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
3622     }
3623     else {
3624       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
3625       if (*cp2 == '.')      *(cp1++) = '_';
3626       else                  *(cp1++) =  *cp2;
3627       infront = 1;
3628     }
3629   }
3630   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3631   if (hasdir) *(cp1++) = ']';
3632   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
3633   while (*cp2) *(cp1++) = *(cp2++);
3634   *cp1 = '\0';
3635
3636   return rslt;
3637
3638 }  /* end of do_tovmsspec() */
3639 /*}}}*/
3640 /* External entry points */
3641 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3642 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3643
3644 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3645 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3646   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3647   int vmslen;
3648   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3649
3650   if (path == NULL) return NULL;
3651   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3652   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3653   if (buf) return buf;
3654   else if (ts) {
3655     vmslen = strlen(vmsified);
3656     New(1317,cp,vmslen+1,char);
3657     memcpy(cp,vmsified,vmslen);
3658     cp[vmslen] = '\0';
3659     return cp;
3660   }
3661   else {
3662     strcpy(__tovmspath_retbuf,vmsified);
3663     return __tovmspath_retbuf;
3664   }
3665
3666 }  /* end of do_tovmspath() */
3667 /*}}}*/
3668 /* External entry points */
3669 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3670 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3671
3672
3673 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3674 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3675   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3676   int unixlen;
3677   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3678
3679   if (path == NULL) return NULL;
3680   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3681   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3682   if (buf) return buf;
3683   else if (ts) {
3684     unixlen = strlen(unixified);
3685     New(1317,cp,unixlen+1,char);
3686     memcpy(cp,unixified,unixlen);
3687     cp[unixlen] = '\0';
3688     return cp;
3689   }
3690   else {
3691     strcpy(__tounixpath_retbuf,unixified);
3692     return __tounixpath_retbuf;
3693   }
3694
3695 }  /* end of do_tounixpath() */
3696 /*}}}*/
3697 /* External entry points */
3698 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3699 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3700
3701 /*
3702  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
3703  *
3704  *****************************************************************************
3705  *                                                                           *
3706  *  Copyright (C) 1989-1994 by                                               *
3707  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
3708  *                                                                           *
3709  *  Permission is hereby  granted for the reproduction of this software,     *
3710  *  on condition that this copyright notice is included in the reproduction, *
3711  *  and that such reproduction is not for purposes of profit or material     *
3712  *  gain.                                                                    *
3713  *                                                                           *
3714  *  27-Aug-1994 Modified for inclusion in perl5                              *
3715  *              by Charles Bailey  bailey@newman.upenn.edu                   *
3716  *****************************************************************************
3717  */
3718
3719 /*
3720  * getredirection() is intended to aid in porting C programs
3721  * to VMS (Vax-11 C).  The native VMS environment does not support
3722  * '>' and '<' I/O redirection, or command line wild card expansion,
3723  * or a command line pipe mechanism using the '|' AND background
3724  * command execution '&'.  All of these capabilities are provided to any
3725  * C program which calls this procedure as the first thing in the
3726  * main program.
3727  * The piping mechanism will probably work with almost any 'filter' type
3728  * of program.  With suitable modification, it may useful for other
3729  * portability problems as well.
3730  *
3731  * Author:  Mark Pizzolato      mark@infocomm.com
3732  */
3733 struct list_item
3734     {
3735     struct list_item *next;
3736     char *value;
3737     };
3738
3739 static void add_item(struct list_item **head,
3740                      struct list_item **tail,
3741                      char *value,
3742                      int *count);
3743
3744 static void mp_expand_wild_cards(pTHX_ char *item,
3745                                 struct list_item **head,
3746                                 struct list_item **tail,
3747                                 int *count);
3748
3749 static int background_process(int argc, char **argv);
3750
3751 static void pipe_and_fork(pTHX_ char **cmargv);
3752
3753 /*{{{ void getredirection(int *ac, char ***av)*/
3754 static void
3755 mp_getredirection(pTHX_ int *ac, char ***av)
3756 /*
3757  * Process vms redirection arg's.  Exit if any error is seen.
3758  * If getredirection() processes an argument, it is erased
3759  * from the vector.  getredirection() returns a new argc and argv value.
3760  * In the event that a background command is requested (by a trailing "&"),
3761  * this routine creates a background subprocess, and simply exits the program.
3762  *
3763  * Warning: do not try to simplify the code for vms.  The code
3764  * presupposes that getredirection() is called before any data is
3765  * read from stdin or written to stdout.
3766  *
3767  * Normal usage is as follows:
3768  *
3769  *      main(argc, argv)
3770  *      int             argc;
3771  *      char            *argv[];
3772  *      {
3773  *              getredirection(&argc, &argv);
3774  *      }
3775  */
3776 {
3777     int                 argc = *ac;     /* Argument Count         */
3778     char                **argv = *av;   /* Argument Vector        */
3779     char                *ap;            /* Argument pointer       */
3780     int                 j;              /* argv[] index           */
3781     int                 item_count = 0; /* Count of Items in List */
3782     struct list_item    *list_head = 0; /* First Item in List       */
3783     struct list_item    *list_tail;     /* Last Item in List        */
3784     char                *in = NULL;     /* Input File Name          */
3785     char                *out = NULL;    /* Output File Name         */
3786     char                *outmode = "w"; /* Mode to Open Output File */
3787     char                *err = NULL;    /* Error File Name          */
3788     char                *errmode = "w"; /* Mode to Open Error File  */
3789     int                 cmargc = 0;     /* Piped Command Arg Count  */
3790     char                **cmargv = NULL;/* Piped Command Arg Vector */
3791
3792     /*
3793      * First handle the case where the last thing on the line ends with
3794      * a '&'.  This indicates the desire for the command to be run in a
3795      * subprocess, so we satisfy that desire.
3796      */
3797     ap = argv[argc-1];
3798     if (0 == strcmp("&", ap))
3799         exit(background_process(--argc, argv));
3800     if (*ap && '&' == ap[strlen(ap)-1])
3801         {
3802         ap[strlen(ap)-1] = '\0';
3803         exit(background_process(argc, argv));
3804         }
3805     /*
3806      * Now we handle the general redirection cases that involve '>', '>>',
3807      * '<', and pipes '|'.
3808      */
3809     for (j = 0; j < argc; ++j)
3810         {
3811         if (0 == strcmp("<", argv[j]))
3812             {
3813             if (j+1 >= argc)
3814                 {
3815                 fprintf(stderr,"No input file after < on command line");
3816                 exit(LIB$_WRONUMARG);
3817                 }
3818             in = argv[++j];
3819             continue;
3820             }
3821         if ('<' == *(ap = argv[j]))
3822             {
3823             in = 1 + ap;
3824             continue;
3825             }
3826         if (0 == strcmp(">", ap))
3827             {
3828             if (j+1 >= argc)
3829                 {
3830                 fprintf(stderr,"No output file after > on command line");
3831                 exit(LIB$_WRONUMARG);
3832                 }
3833             out = argv[++j];
3834             continue;
3835             }
3836         if ('>' == *ap)
3837             {
3838             if ('>' == ap[1])
3839                 {
3840                 outmode = "a";
3841                 if ('\0' == ap[2])
3842                     out = argv[++j];
3843                 else
3844                     out = 2 + ap;
3845                 }
3846             else
3847                 out = 1 + ap;
3848             if (j >= argc)
3849                 {
3850                 fprintf(stderr,"No output file after > or >> on command line");
3851                 exit(LIB$_WRONUMARG);
3852                 }
3853             continue;
3854             }
3855         if (('2' == *ap) && ('>' == ap[1]))
3856             {
3857             if ('>' == ap[2])
3858                 {
3859                 errmode = "a";
3860                 if ('\0' == ap[3])
3861                     err = argv[++j];
3862                 else
3863                     err = 3 + ap;
3864                 }
3865             else
3866                 if ('\0' == ap[2])
3867                     err = argv[++j];
3868                 else
3869                     err = 2 + ap;
3870             if (j >= argc)
3871                 {
3872                 fprintf(stderr,"No output file after 2> or 2>> on command line");
3873                 exit(LIB$_WRONUMARG);
3874                 }
3875             continue;
3876             }
3877         if (0 == strcmp("|", argv[j]))
3878             {
3879             if (j+1 >= argc)
3880                 {
3881                 fprintf(stderr,"No command into which to pipe on command line");
3882                 exit(LIB$_WRONUMARG);
3883                 }
3884             cmargc = argc-(j+1);
3885             cmargv = &argv[j+1];
3886             argc = j;
3887             continue;
3888             }
3889         if ('|' == *(ap = argv[j]))
3890             {
3891             ++argv[j];
3892             cmargc = argc-j;
3893             cmargv = &argv[j];
3894             argc = j;
3895             continue;
3896             }
3897         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3898         }
3899     /*
3900      * Allocate and fill in the new argument vector, Some Unix's terminate
3901      * the list with an extra null pointer.
3902      */
3903     New(1302, argv, item_count+1, char *);
3904     *av = argv;
3905     for (j = 0; j < item_count; ++j, list_head = list_head->next)
3906         argv[j] = list_head->value;
3907     *ac = item_count;
3908     if (cmargv != NULL)
3909         {
3910         if (out != NULL)
3911             {
3912             fprintf(stderr,"'|' and '>' may not both be specified on command line");
3913             exit(LIB$_INVARGORD);
3914             }
3915         pipe_and_fork(aTHX_ cmargv);
3916         }
3917
3918     /* Check for input from a pipe (mailbox) */
3919
3920     if (in == NULL && 1 == isapipe(0))
3921         {
3922         char mbxname[L_tmpnam];
3923         long int bufsize;
3924         long int dvi_item = DVI$_DEVBUFSIZ;
3925         $DESCRIPTOR(mbxnam, "");
3926         $DESCRIPTOR(mbxdevnam, "");
3927
3928         /* Input from a pipe, reopen it in binary mode to disable       */
3929         /* carriage control processing.                                 */
3930
3931         fgetname(stdin, mbxname);
3932         mbxnam.dsc$a_pointer = mbxname;
3933         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3934         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3935         mbxdevnam.dsc$a_pointer = mbxname;
3936         mbxdevnam.dsc$w_length = sizeof(mbxname);
3937         dvi_item = DVI$_DEVNAM;
3938         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3939         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3940         set_errno(0);
3941         set_vaxc_errno(1);
3942         freopen(mbxname, "rb", stdin);
3943         if (errno != 0)
3944             {
3945             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3946             exit(vaxc$errno);
3947             }
3948         }
3949     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3950         {
3951         fprintf(stderr,"Can't open input file %s as stdin",in);
3952         exit(vaxc$errno);
3953         }
3954     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3955         {
3956         fprintf(stderr,"Can't open output file %s as stdout",out);
3957         exit(vaxc$errno);
3958         }
3959         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
3960
3961     if (err != NULL) {
3962         if (strcmp(err,"&1") == 0) {
3963             dup2(fileno(stdout), fileno(stderr));
3964             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
3965         } else {
3966         FILE *tmperr;
3967         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3968             {
3969             fprintf(stderr,"Can't open error file %s as stderr",err);
3970             exit(vaxc$errno);
3971             }
3972             fclose(tmperr);
3973            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
3974                 {
3975                 exit(vaxc$errno);
3976                 }
3977             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
3978         }
3979         }
3980 #ifdef ARGPROC_DEBUG
3981     PerlIO_printf(Perl_debug_log, "Arglist:\n");
3982     for (j = 0; j < *ac;  ++j)
3983         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3984 #endif
3985    /* Clear errors we may have hit expanding wildcards, so they don't
3986       show up in Perl's $! later */
3987    set_errno(0); set_vaxc_errno(1);
3988 }  /* end of getredirection() */
3989 /*}}}*/
3990
3991 static void add_item(struct list_item **head,
3992                      struct list_item **tail,
3993                      char *value,
3994                      int *count)
3995 {
3996     if (*head == 0)
3997         {
3998         New(1303,*head,1,struct list_item);
3999         *tail = *head;
4000         }
4001     else {
4002         New(1304,(*tail)->next,1,struct list_item);
4003         *tail = (*tail)->next;
4004         }
4005     (*tail)->value = value;
4006     ++(*count);
4007 }
4008
4009 static void mp_expand_wild_cards(pTHX_ char *item,
4010                               struct list_item **head,
4011                               struct list_item **tail,
4012                               int *count)
4013 {
4014 int expcount = 0;
4015 unsigned long int context = 0;
4016 int isunix = 0;
4017 char *had_version;
4018 char *had_device;
4019 int had_directory;
4020 char *devdir,*cp;
4021 char vmsspec[NAM$C_MAXRSS+1];
4022 $DESCRIPTOR(filespec, "");
4023 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4024 $DESCRIPTOR(resultspec, "");
4025 unsigned long int zero = 0, sts;
4026
4027     for (cp = item; *cp; cp++) {
4028         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4029         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4030     }
4031     if (!*cp || isspace(*cp))
4032         {
4033         add_item(head, tail, item, count);
4034         return;
4035         }
4036     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4037     resultspec.dsc$b_class = DSC$K_CLASS_D;
4038     resultspec.dsc$a_pointer = NULL;
4039     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4040       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4041     if (!isunix || !filespec.dsc$a_pointer)
4042       filespec.dsc$a_pointer = item;
4043     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4044     /*
4045      * Only return version specs, if the caller specified a version
4046      */
4047     had_version = strchr(item, ';');
4048     /*
4049      * Only return device and directory specs, if the caller specifed either.
4050      */
4051     had_device = strchr(item, ':');
4052     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4053
4054     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4055                                   &defaultspec, 0, 0, &zero))))
4056         {
4057         char *string;
4058         char *c;
4059
4060         New(1305,string,resultspec.dsc$w_length+1,char);
4061         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4062         string[resultspec.dsc$w_length] = '\0';
4063         if (NULL == had_version)
4064             *((char *)strrchr(string, ';')) = '\0';
4065         if ((!had_directory) && (had_device == NULL))
4066             {
4067             if (NULL == (devdir = strrchr(string, ']')))
4068                 devdir = strrchr(string, '>');
4069             strcpy(string, devdir + 1);
4070             }
4071         /*
4072          * Be consistent with what the C RTL has already done to the rest of
4073          * the argv items and lowercase all of these names.
4074          */
4075         for (c = string; *c; ++c)
4076             if (isupper(*c))
4077                 *c = tolower(*c);
4078         if (isunix) trim_unixpath(string,item,1);
4079         add_item(head, tail, string, count);
4080         ++expcount;
4081         }
4082     if (sts != RMS$_NMF)
4083         {
4084         set_vaxc_errno(sts);
4085         switch (sts)
4086             {
4087             case RMS$_FNF: case RMS$_DNF:
4088                 set_errno(ENOENT); break;
4089             case RMS$_DIR:
4090                 set_errno(ENOTDIR); break;
4091             case RMS$_DEV:
4092                 set_errno(ENODEV); break;
4093             case RMS$_FNM: case RMS$_SYN:
4094                 set_errno(EINVAL); break;
4095             case RMS$_PRV:
4096                 set_errno(EACCES); break;
4097             default:
4098                 _ckvmssts_noperl(sts);
4099             }
4100         }
4101     if (expcount == 0)
4102         add_item(head, tail, item, count);
4103     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4104     _ckvmssts_noperl(lib$find_file_end(&context));
4105 }
4106
4107 static int child_st[2];/* Event Flag set when child process completes   */
4108
4109 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
4110
4111 static unsigned long int exit_handler(int *status)
4112 {
4113 short iosb[4];
4114
4115     if (0 == child_st[0])
4116         {
4117 #ifdef ARGPROC_DEBUG
4118         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4119 #endif
4120         fflush(stdout);     /* Have to flush pipe for binary data to    */
4121                             /* terminate properly -- <tp@mccall.com>    */
4122         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4123         sys$dassgn(child_chan);
4124         fclose(stdout);
4125         sys$synch(0, child_st);
4126         }
4127     return(1);
4128 }
4129
4130 static void sig_child(int chan)
4131 {
4132 #ifdef ARGPROC_DEBUG
4133     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4134 #endif
4135     if (child_st[0] == 0)
4136         child_st[0] = 1;
4137 }
4138
4139 static struct exit_control_block exit_block =
4140     {
4141     0,
4142     exit_handler,
4143     1,
4144     &exit_block.exit_status,
4145     0
4146     };
4147
4148 static void
4149 pipe_and_fork(pTHX_ char **cmargv)
4150 {
4151     PerlIO *fp;
4152     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4153     int sts, j, l, ismcr, quote, tquote = 0;
4154
4155     sts = setup_cmddsc(cmargv[0],0,&quote);
4156
4157     j = l = 0;
4158     p = subcmd;
4159     q = cmargv[0];
4160     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
4161               && toupper(*(q+2)) == 'R' && !*(q+3);
4162
4163     while (q && l < MAX_DCL_LINE_LENGTH) {
4164         if (!*q) {
4165             if (j > 0 && quote) {
4166                 *p++ = '"';
4167                 l++;
4168             }
4169             q = cmargv[++j];
4170             if (q) {
4171                 if (ismcr && j > 1) quote = 1;
4172                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
4173                 *p++ = ' ';
4174                 l++;
4175                 if (quote || tquote) {
4176                     *p++ = '"';
4177                     l++;
4178                 }
4179         }
4180         } else {
4181             if ((quote||tquote) && *q == '"') {
4182                 *p++ = '"';
4183                 l++;
4184         }
4185             *p++ = *q++;
4186             l++;
4187         }
4188     }
4189     *p = '\0';
4190
4191     store_pipelocs();                   /* gets redone later */
4192     fp = safe_popen(subcmd,"wbF",&sts);
4193     if (fp == Nullfp) {
4194         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4195         }
4196 }
4197
4198 static int background_process(int argc, char **argv)
4199 {
4200 char command[2048] = "$";
4201 $DESCRIPTOR(value, "");
4202 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4203 static $DESCRIPTOR(null, "NLA0:");
4204 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4205 char pidstring[80];
4206 $DESCRIPTOR(pidstr, "");
4207 int pid;
4208 unsigned long int flags = 17, one = 1, retsts;
4209
4210     strcat(command, argv[0]);
4211     while (--argc)
4212         {
4213         strcat(command, " \"");
4214         strcat(command, *(++argv));
4215         strcat(command, "\"");
4216         }
4217     value.dsc$a_pointer = command;
4218     value.dsc$w_length = strlen(value.dsc$a_pointer);
4219     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4220     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4221     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4222         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4223     }
4224     else {
4225         _ckvmssts_noperl(retsts);
4226     }
4227 #ifdef ARGPROC_DEBUG
4228     PerlIO_printf(Perl_debug_log, "%s\n", command);
4229 #endif
4230     sprintf(pidstring, "%08X", pid);
4231     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4232     pidstr.dsc$a_pointer = pidstring;
4233     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4234     lib$set_symbol(&pidsymbol, &pidstr);
4235     return(SS$_NORMAL);
4236 }
4237 /*}}}*/
4238 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4239
4240
4241 /* OS-specific initialization at image activation (not thread startup) */
4242 /* Older VAXC header files lack these constants */
4243 #ifndef JPI$_RIGHTS_SIZE
4244 #  define JPI$_RIGHTS_SIZE 817
4245 #endif
4246 #ifndef KGB$M_SUBSYSTEM
4247 #  define KGB$M_SUBSYSTEM 0x8
4248 #endif
4249
4250 /*{{{void vms_image_init(int *, char ***)*/
4251 void
4252 vms_image_init(int *argcp, char ***argvp)
4253 {
4254   char eqv[LNM$C_NAMLENGTH+1] = "";
4255   unsigned int len, tabct = 8, tabidx = 0;
4256   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4257   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4258   unsigned short int dummy, rlen;
4259   struct dsc$descriptor_s **tabvec;
4260 #if defined(PERL_IMPLICIT_CONTEXT)
4261   pTHX = NULL;
4262 #endif
4263   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
4264                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
4265                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4266                                  {          0,                0,    0,      0} };
4267
4268   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4269   _ckvmssts_noperl(iosb[0]);
4270   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4271     if (iprv[i]) {           /* Running image installed with privs? */
4272       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
4273       will_taint = TRUE;
4274       break;
4275     }
4276   }
4277   /* Rights identifiers might trigger tainting as well. */
4278   if (!will_taint && (rlen || rsz)) {
4279     while (rlen < rsz) {
4280       /* We didn't get all the identifiers on the first pass.  Allocate a
4281        * buffer much larger than $GETJPI wants (rsz is size in bytes that
4282        * were needed to hold all identifiers at time of last call; we'll
4283        * allocate that many unsigned long ints), and go back and get 'em.
4284        * If it gave us less than it wanted to despite ample buffer space,
4285        * something's broken.  Is your system missing a system identifier?
4286        */
4287       if (rsz <= jpilist[1].buflen) {
4288          /* Perl_croak accvios when used this early in startup. */
4289          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4290                          rsz, (unsigned long) jpilist[1].buflen,
4291                          "Check your rights database for corruption.\n");
4292          exit(SS$_ABORT);
4293       }
4294       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4295       jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4296       jpilist[1].buflen = rsz * sizeof(unsigned long int);
4297       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4298       _ckvmssts_noperl(iosb[0]);
4299     }
4300     mask = jpilist[1].bufadr;
4301     /* Check attribute flags for each identifier (2nd longword); protected
4302      * subsystem identifiers trigger tainting.
4303      */
4304     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4305       if (mask[i] & KGB$M_SUBSYSTEM) {
4306         will_taint = TRUE;
4307         break;
4308       }
4309     }
4310     if (mask != rlst) Safefree(mask);
4311   }
4312   /* We need to use this hack to tell Perl it should run with tainting,
4313    * since its tainting flag may be part of the PL_curinterp struct, which
4314    * hasn't been allocated when vms_image_init() is called.
4315    */
4316   if (will_taint) {
4317     char ***newap;
4318     New(1320,newap,*argcp+2,char **);
4319     newap[0] = argvp[0];
4320     *newap[1] = "-T";
4321     Copy(argvp[1],newap[2],*argcp-1,char **);
4322     /* We orphan the old argv, since we don't know where it's come from,
4323      * so we don't know how to free it.
4324      */
4325     *argcp++; argvp = newap;
4326   }
4327   else {  /* Did user explicitly request tainting? */
4328     int i;
4329     char *cp, **av = *argvp;
4330     for (i = 1; i < *argcp; i++) {
4331       if (*av[i] != '-') break;
4332       for (cp = av[i]+1; *cp; cp++) {
4333         if (*cp == 'T') { will_taint = 1; break; }
4334         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4335                   strchr("DFIiMmx",*cp)) break;
4336       }
4337       if (will_taint) break;
4338     }
4339   }
4340
4341   for (tabidx = 0;
4342        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4343        tabidx++) {
4344     if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4345     else if (tabidx >= tabct) {
4346       tabct += 8;
4347       Renew(tabvec,tabct,struct dsc$descriptor_s *);
4348     }
4349     New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4350     tabvec[tabidx]->dsc$w_length  = 0;
4351     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
4352     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
4353     tabvec[tabidx]->dsc$a_pointer = NULL;
4354     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4355   }
4356   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4357
4358   getredirection(argcp,argvp);
4359 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4360   {
4361 # include <reentrancy.h>
4362   (void) decc$set_reentrancy(C$C_MULTITHREAD);
4363   }
4364 #endif
4365   return;
4366 }
4367 /*}}}*/
4368
4369
4370 /* trim_unixpath()
4371  * Trim Unix-style prefix off filespec, so it looks like what a shell
4372  * glob expansion would return (i.e. from specified prefix on, not
4373  * full path).  Note that returned filespec is Unix-style, regardless
4374  * of whether input filespec was VMS-style or Unix-style.
4375  *
4376  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4377  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
4378  * vector of options; at present, only bit 0 is used, and if set tells
4379  * trim unixpath to try the current default directory as a prefix when
4380  * presented with a possibly ambiguous ... wildcard.
4381  *
4382  * Returns !=0 on success, with trimmed filespec replacing contents of
4383  * fspec, and 0 on failure, with contents of fpsec unchanged.
4384  */
4385 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4386 int
4387 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4388 {
4389   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4390        *template, *base, *end, *cp1, *cp2;
4391   register int tmplen, reslen = 0, dirs = 0;
4392
4393   if (!wildspec || !fspec) return 0;
4394   if (strpbrk(wildspec,"]>:") != NULL) {
4395     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4396     else template = unixwild;
4397   }
4398   else template = wildspec;
4399   if (strpbrk(fspec,"]>:") != NULL) {
4400     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4401     else base = unixified;
4402     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4403      * check to see that final result fits into (isn't longer than) fspec */
4404     reslen = strlen(fspec);
4405   }
4406   else base = fspec;
4407
4408   /* No prefix or absolute path on wildcard, so nothing to remove */
4409   if (!*template || *template == '/') {
4410     if (base == fspec) return 1;
4411     tmplen = strlen(unixified);
4412     if (tmplen > reslen) return 0;  /* not enough space */
4413     /* Copy unixified resultant, including trailing NUL */
4414     memmove(fspec,unixified,tmplen+1);
4415     return 1;
4416   }
4417
4418   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
4419   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4420     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4421     for (cp1 = end ;cp1 >= base; cp1--)
4422       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4423         { cp1++; break; }
4424     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4425     return 1;
4426   }
4427   else {
4428     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4429     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4430     int ells = 1, totells, segdirs, match;
4431     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4432                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4433
4434     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4435     totells = ells;
4436     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4437     if (ellipsis == template && opts & 1) {
4438       /* Template begins with an ellipsis.  Since we can't tell how many
4439        * directory names at the front of the resultant to keep for an
4440        * arbitrary starting point, we arbitrarily choose the current
4441        * default directory as a starting point.  If it's there as a prefix,
4442        * clip it off.  If not, fall through and act as if the leading
4443        * ellipsis weren't there (i.e. return shortest possible path that
4444        * could match template).
4445        */
4446       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4447       for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4448         if (_tolower(*cp1) != _tolower(*cp2)) break;
4449       segdirs = dirs - totells;  /* Min # of dirs we must have left */
4450       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4451       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4452         memcpy(fspec,cp2+1,end - cp2);
4453         return 1;
4454       }
4455     }
4456     /* First off, back up over constant elements at end of path */
4457     if (dirs) {
4458       for (front = end ; front >= base; front--)
4459          if (*front == '/' && !dirs--) { front++; break; }
4460     }
4461     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4462          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
4463     if (cp1 != '\0') return 0;  /* Path too long. */
4464     lcend = cp2;
4465     *cp2 = '\0';  /* Pick up with memcpy later */
4466     lcfront = lcres + (front - base);
4467     /* Now skip over each ellipsis and try to match the path in front of it. */
4468     while (ells--) {
4469       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4470         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
4471             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
4472       if (cp1 < template) break; /* template started with an ellipsis */
4473       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4474         ellipsis = cp1; continue;
4475       }
4476       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4477       nextell = cp1;
4478       for (segdirs = 0, cp2 = tpl;
4479            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4480            cp1++, cp2++) {
4481          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4482          else *cp2 = _tolower(*cp1);  /* else lowercase for match */
4483          if (*cp2 == '/') segdirs++;
4484       }
4485       if (cp1 != ellipsis - 1) return 0; /* Path too long */
4486       /* Back up at least as many dirs as in template before matching */
4487       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4488         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4489       for (match = 0; cp1 > lcres;) {
4490         resdsc.dsc$a_pointer = cp1;
4491         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4492           match++;
4493           if (match == 1) lcfront = cp1;
4494         }
4495         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4496       }
4497       if (!match) return 0;  /* Can't find prefix ??? */
4498       if (match > 1 && opts & 1) {
4499         /* This ... wildcard could cover more than one set of dirs (i.e.
4500          * a set of similar dir names is repeated).  If the template
4501          * contains more than 1 ..., upstream elements could resolve the
4502          * ambiguity, but it's not worth a full backtracking setup here.
4503          * As a quick heuristic, clip off the current default directory
4504          * if it's present to find the trimmed spec, else use the
4505          * shortest string that this ... could cover.
4506          */
4507         char def[NAM$C_MAXRSS+1], *st;
4508
4509         if (getcwd(def, sizeof def,0) == NULL) return 0;
4510         for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4511           if (_tolower(*cp1) != _tolower(*cp2)) break;
4512         segdirs = dirs - totells;  /* Min # of dirs we must have left */
4513         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4514         if (*cp1 == '\0' && *cp2 == '/') {
4515           memcpy(fspec,cp2+1,end - cp2);
4516           return 1;
4517         }
4518         /* Nope -- stick with lcfront from above and keep going. */
4519       }
4520     }
4521     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4522     return 1;
4523     ellipsis = nextell;
4524   }
4525
4526 }  /* end of trim_unixpath() */
4527 /*}}}*/
4528
4529
4530 /*
4531  *  VMS readdir() routines.
4532  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4533  *
4534  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
4535  *  Minor modifications to original routines.
4536  */
4537
4538     /* Number of elements in vms_versions array */
4539 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
4540
4541 /*
4542  *  Open a directory, return a handle for later use.
4543  */
4544 /*{{{ DIR *opendir(char*name) */
4545 DIR *
4546 Perl_opendir(pTHX_ char *name)
4547 {
4548     DIR *dd;
4549     char dir[NAM$C_MAXRSS+1];
4550     Stat_t sb;
4551
4552     if (do_tovmspath(name,dir,0) == NULL) {
4553       return NULL;
4554     }
4555     if (flex_stat(dir,&sb) == -1) return NULL;
4556     if (!S_ISDIR(sb.st_mode)) {
4557       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
4558       return NULL;
4559     }
4560     if (!cando_by_name(S_IRUSR,0,dir)) {
4561       set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4562       return NULL;
4563     }
4564     /* Get memory for the handle, and the pattern. */
4565     New(1306,dd,1,DIR);
4566     New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4567
4568     /* Fill in the fields; mainly playing with the descriptor. */
4569     (void)sprintf(dd->pattern, "%s*.*",dir);
4570     dd->context = 0;
4571     dd->count = 0;
4572     dd->vms_wantversions = 0;
4573     dd->pat.dsc$a_pointer = dd->pattern;
4574     dd->pat.dsc$w_length = strlen(dd->pattern);
4575     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4576     dd->pat.dsc$b_class = DSC$K_CLASS_S;
4577
4578     return dd;
4579 }  /* end of opendir() */
4580 /*}}}*/
4581
4582 /*
4583  *  Set the flag to indicate we want versions or not.
4584  */
4585 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4586 void
4587 vmsreaddirversions(DIR *dd, int flag)
4588 {
4589     dd->vms_wantversions = flag;
4590 }
4591 /*}}}*/
4592
4593 /*
4594  *  Free up an opened directory.
4595  */
4596 /*{{{ void closedir(DIR *dd)*/
4597 void
4598 closedir(DIR *dd)
4599 {
4600     (void)lib$find_file_end(&dd->context);
4601     Safefree(dd->pattern);
4602     Safefree((char *)dd);
4603 }
4604 /*}}}*/
4605
4606 /*
4607  *  Collect all the version numbers for the current file.
4608  */
4609 static void
4610 collectversions(pTHX_ DIR *dd)
4611 {
4612     struct dsc$descriptor_s     pat;
4613     struct dsc$descriptor_s     res;
4614     struct dirent *e;
4615     char *p, *text, buff[sizeof dd->entry.d_name];
4616     int i;
4617     unsigned long context, tmpsts;
4618
4619     /* Convenient shorthand. */
4620     e = &dd->entry;
4621
4622     /* Add the version wildcard, ignoring the "*.*" put on before */
4623     i = strlen(dd->pattern);
4624     New(1308,text,i + e->d_namlen + 3,char);
4625     (void)strcpy(text, dd->pattern);
4626     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4627
4628     /* Set up the pattern descriptor. */
4629     pat.dsc$a_pointer = text;
4630     pat.dsc$w_length = i + e->d_namlen - 1;
4631     pat.dsc$b_dtype = DSC$K_DTYPE_T;
4632     pat.dsc$b_class = DSC$K_CLASS_S;
4633
4634     /* Set up result descriptor. */
4635     res.dsc$a_pointer = buff;
4636     res.dsc$w_length = sizeof buff - 2;
4637     res.dsc$b_dtype = DSC$K_DTYPE_T;
4638     res.dsc$b_class = DSC$K_CLASS_S;
4639
4640     /* Read files, collecting versions. */
4641     for (context = 0, e->vms_verscount = 0;
4642          e->vms_verscount < VERSIZE(e);
4643          e->vms_verscount++) {
4644         tmpsts = lib$find_file(&pat, &res, &context);
4645         if (tmpsts == RMS$_NMF || context == 0) break;
4646         _ckvmssts(tmpsts);
4647         buff[sizeof buff - 1] = '\0';
4648         if ((p = strchr(buff, ';')))
4649             e->vms_versions[e->vms_verscount] = atoi(p + 1);
4650         else
4651             e->vms_versions[e->vms_verscount] = -1;
4652     }
4653
4654     _ckvmssts(lib$find_file_end(&context));
4655     Safefree(text);
4656
4657 }  /* end of collectversions() */
4658
4659 /*
4660  *  Read the next entry from the directory.
4661  */
4662 /*{{{ struct dirent *readdir(DIR *dd)*/
4663 struct dirent *
4664 Perl_readdir(pTHX_ DIR *dd)
4665 {
4666     struct dsc$descriptor_s     res;
4667     char *p, buff[sizeof dd->entry.d_name];
4668     unsigned long int tmpsts;
4669
4670     /* Set up result descriptor, and get next file. */
4671     res.dsc$a_pointer = buff;
4672     res.dsc$w_length = sizeof buff - 2;
4673     res.dsc$b_dtype = DSC$K_DTYPE_T;
4674     res.dsc$b_class = DSC$K_CLASS_S;
4675     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4676     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
4677     if (!(tmpsts & 1)) {
4678       set_vaxc_errno(tmpsts);
4679       switch (tmpsts) {
4680         case RMS$_PRV:
4681           set_errno(EACCES); break;
4682         case RMS$_DEV:
4683           set_errno(ENODEV); break;
4684         case RMS$_DIR:
4685           set_errno(ENOTDIR); break;
4686         case RMS$_FNF: case RMS$_DNF:
4687           set_errno(ENOENT); break;
4688         default:
4689           set_errno(EVMSERR);
4690       }
4691       return NULL;
4692     }
4693     dd->count++;