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