vms/vms.c

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