vms/vms.c

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