vms/vms.c

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