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_5005THREADS)
 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_5005THREADS)
 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_5005THREADS) || 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     sts = setup_cmddsc(aTHX_ cmd,0);
2065     if (!(sts & 1)) {
2066       switch (sts) {
2067         case RMS$_FNF:  case RMS$_DNF:
2068           set_errno(ENOENT); break;
2069         case RMS$_DIR:
2070           set_errno(ENOTDIR); break;
2071         case RMS$_DEV:
2072           set_errno(ENODEV); break;
2073         case RMS$_PRV:
2074           set_errno(EACCES); break;
2075         case RMS$_SYN:
2076           set_errno(EINVAL); break;
2077         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2078           set_errno(E2BIG); break;
2079         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2080           _ckvmssts(sts); /* fall through */
2081         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2082           set_errno(EVMSERR);
2083       }
2084       set_vaxc_errno(sts);
2085       if (ckWARN(WARN_PIPE)) {
2086         Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2087       }
2088       return Nullfp;
2089     }
2090     New(1301,info,1,Info);
2091
2092     info->mode = *mode;
2093     info->done = FALSE;
2094     info->completion = 0;
2095     info->closing    = FALSE;
2096     info->in         = 0;
2097     info->out        = 0;
2098     info->err        = 0;
2099     info->in_done    = TRUE;
2100     info->out_done   = TRUE;
2101     info->err_done   = TRUE;
2102     in[0] = out[0] = err[0] = '\0';
2103
2104     if (*mode == 'r') {             /* piping from subroutine */
2105
2106         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2107         if (info->out) {
2108             info->out->pipe_done = &info->out_done;
2109             info->out_done = FALSE;
2110             info->out->info = info;
2111         }
2112         info->fp  = PerlIO_open(mbx, mode);
2113         if (!info->fp && info->out) {
2114             sys$cancel(info->out->chan_out);
2115
2116             while (!info->out_done) {
2117                 int done;
2118                 _ckvmssts(sys$setast(0));
2119                 done = info->out_done;
2120                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2121                 _ckvmssts(sys$setast(1));
2122                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2123             }
2124
2125             if (info->out->buf) Safefree(info->out->buf);
2126             Safefree(info->out);
2127             Safefree(info);
2128             return Nullfp;
2129         }
2130
2131         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2132         if (info->err) {
2133             info->err->pipe_done = &info->err_done;
2134             info->err_done = FALSE;
2135             info->err->info = info;
2136         }
2137
2138     } else {                        /* piping to subroutine , mode=w*/
2139
2140         info->in = pipe_tochild_setup(aTHX_ in,mbx);
2141         info->fp  = PerlIO_open(mbx, mode);
2142         if (info->in) {
2143             info->in->pipe_done = &info->in_done;
2144             info->in_done = FALSE;
2145             info->in->info = info;
2146         }
2147
2148         /* error cleanup */
2149         if (!info->fp && info->in) {
2150             info->done = TRUE;
2151             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2152                               0, 0, 0, 0, 0, 0, 0, 0));
2153
2154             while (!info->in_done) {
2155                 int done;
2156                 _ckvmssts(sys$setast(0));
2157                 done = info->in_done;
2158                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2159                 _ckvmssts(sys$setast(1));
2160                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2161             }
2162
2163             if (info->in->buf) Safefree(info->in->buf);
2164             Safefree(info->in);
2165             Safefree(info);
2166             return Nullfp;
2167         }
2168
2169
2170         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2171         if (info->out) {
2172             info->out->pipe_done = &info->out_done;
2173             info->out_done = FALSE;
2174             info->out->info = info;
2175         }
2176
2177         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2178         if (info->err) {
2179             info->err->pipe_done = &info->err_done;
2180             info->err_done = FALSE;
2181             info->err->info = info;
2182         }
2183     }
2184
2185     symbol[MAX_DCL_SYMBOL] = '\0';
2186
2187     strncpy(symbol, in, MAX_DCL_SYMBOL);
2188     d_symbol.dsc$w_length = strlen(symbol);
2189     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2190
2191     strncpy(symbol, err, MAX_DCL_SYMBOL);
2192     d_symbol.dsc$w_length = strlen(symbol);
2193     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2194
2195     strncpy(symbol, out, MAX_DCL_SYMBOL);
2196     d_symbol.dsc$w_length = strlen(symbol);
2197     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2198
2199     p = VMScmd.dsc$a_pointer;
2200     while (*p && *p != '\n') p++;
2201     *p = '\0';                                  /* truncate on \n */
2202     p = VMScmd.dsc$a_pointer;
2203     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
2204     if (*p == '$') p++;                         /* remove leading $ */
2205     while (*p == ' ' || *p == '\t') p++;
2206     strncpy(symbol, p, MAX_DCL_SYMBOL);
2207     d_symbol.dsc$w_length = strlen(symbol);
2208     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2209
2210     _ckvmssts(sys$setast(0));
2211     info->next=open_pipes;  /* prepend to list */
2212     open_pipes=info;
2213     _ckvmssts(sys$setast(1));
2214     _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2215                       0, &info->pid, &info->completion,
2216                       0, popen_completion_ast,info,0,0,0));
2217
2218     /* if we were using a tempfile, close it now */
2219
2220     if (tpipe) fclose(tpipe);
2221
2222     /* once the subprocess is spawned, its copied the symbols and
2223        we can get rid of ours */
2224
2225     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2226     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
2227     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2228     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2229     vms_execfree(aTHX);
2230
2231     PL_forkprocess = info->pid;
2232     return info->fp;
2233 }  /* end of safe_popen */
2234
2235
2236 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
2237 PerlIO *
2238 Perl_my_popen(pTHX_ char *cmd, char *mode)
2239 {
2240     TAINT_ENV();
2241     TAINT_PROPER("popen");
2242     PERL_FLUSHALL_FOR_CHILD;
2243     return safe_popen(aTHX_ cmd,mode);
2244 }
2245
2246 /*}}}*/
2247
2248 /*{{{  I32 my_pclose(PerlIO *fp)*/
2249 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2250 {
2251     pInfo info, last = NULL;
2252     unsigned long int retsts;
2253     int done, iss;
2254
2255     for (info = open_pipes; info != NULL; last = info, info = info->next)
2256         if (info->fp == fp) break;
2257
2258     if (info == NULL) {  /* no such pipe open */
2259       set_errno(ECHILD); /* quoth POSIX */
2260       set_vaxc_errno(SS$_NONEXPR);
2261       return -1;
2262     }
2263
2264     /* If we were writing to a subprocess, insure that someone reading from
2265      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
2266      * produce an EOF record in the mailbox.
2267      *
2268      *  well, at least sometimes it *does*, so we have to watch out for
2269      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
2270      */
2271
2272      PerlIO_flush(info->fp);   /* first, flush data */
2273
2274     _ckvmssts(sys$setast(0));
2275      info->closing = TRUE;
2276      done = info->done && info->in_done && info->out_done && info->err_done;
2277      /* hanging on write to Perl's input? cancel it */
2278      if (info->mode == 'r' && info->out && !info->out_done) {
2279         if (info->out->chan_out) {
2280             _ckvmssts(sys$cancel(info->out->chan_out));
2281             if (!info->out->chan_in) {   /* EOF generation, need AST */
2282                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2283             }
2284         }
2285      }
2286      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
2287          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2288                            0, 0, 0, 0, 0, 0));
2289     _ckvmssts(sys$setast(1));
2290     PerlIO_close(info->fp);
2291
2292      /*
2293         we have to wait until subprocess completes, but ALSO wait until all
2294         the i/o completes...otherwise we'll be freeing the "info" structure
2295         that the i/o ASTs could still be using...
2296      */
2297
2298      while (!done) {
2299          _ckvmssts(sys$setast(0));
2300          done = info->done && info->in_done && info->out_done && info->err_done;
2301          if (!done) _ckvmssts(sys$clref(pipe_ef));
2302          _ckvmssts(sys$setast(1));
2303          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2304      }
2305      retsts = info->completion;
2306
2307     /* remove from list of open pipes */
2308     _ckvmssts(sys$setast(0));
2309     if (last) last->next = info->next;
2310     else open_pipes = info->next;
2311     _ckvmssts(sys$setast(1));
2312
2313     /* free buffers and structures */
2314
2315     if (info->in) {
2316         if (info->in->buf) Safefree(info->in->buf);
2317         Safefree(info->in);
2318     }
2319     if (info->out) {
2320         if (info->out->buf) Safefree(info->out->buf);
2321         Safefree(info->out);
2322     }
2323     if (info->err) {
2324         if (info->err->buf) Safefree(info->err->buf);
2325         Safefree(info->err);
2326     }
2327     Safefree(info);
2328
2329     return retsts;
2330
2331 }  /* end of my_pclose() */
2332
2333 /* sort-of waitpid; use only with popen() */
2334 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2335 Pid_t
2336 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2337 {
2338     pInfo info;
2339     int done;
2340
2341     for (info = open_pipes; info != NULL; info = info->next)
2342         if (info->pid == pid) break;
2343
2344     if (info != NULL) {  /* we know about this child */
2345       while (!info->done) {
2346           _ckvmssts(sys$setast(0));
2347           done = info->done;
2348           if (!done) _ckvmssts(sys$clref(pipe_ef));
2349           _ckvmssts(sys$setast(1));
2350           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2351       }
2352
2353       *statusp = info->completion;
2354       return pid;
2355     }
2356     else {  /* we haven't heard of this child */
2357       $DESCRIPTOR(intdsc,"0 00:00:01");
2358       unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
2359       unsigned long int interval[2],sts;
2360
2361       if (ckWARN(WARN_EXEC)) {
2362         _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
2363         _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
2364         if (ownerpid != mypid)
2365           Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
2366       }
2367
2368       _ckvmssts(sys$bintim(&intdsc,interval));
2369       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2370         _ckvmssts(sys$schdwk(0,0,interval,0));
2371         _ckvmssts(sys$hiber());
2372       }
2373       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2374       _ckvmssts(sts);
2375
2376       /* There's no easy way to find the termination status a child we're
2377        * not aware of beforehand.  If we're really interested in the future,
2378        * we can go looking for a termination mailbox, or chase after the
2379        * accounting record for the process.
2380        */
2381       *statusp = 0;
2382       return pid;
2383     }
2384
2385 }  /* end of waitpid() */
2386 /*}}}*/
2387 /*}}}*/
2388 /*}}}*/
2389
2390 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2391 char *
2392 my_gconvert(double val, int ndig, int trail, char *buf)
2393 {
2394   static char __gcvtbuf[DBL_DIG+1];
2395   char *loc;
2396
2397   loc = buf ? buf : __gcvtbuf;
2398
2399 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
2400   if (val < 1) {
2401     sprintf(loc,"%.*g",ndig,val);
2402     return loc;
2403   }
2404 #endif
2405
2406   if (val) {
2407     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2408     return gcvt(val,ndig,loc);
2409   }
2410   else {
2411     loc[0] = '0'; loc[1] = '\0';
2412     return loc;
2413   }
2414
2415 }
2416 /*}}}*/
2417
2418
2419 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2420 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2421  * to expand file specification.  Allows for a single default file
2422  * specification and a simple mask of options.  If outbuf is non-NULL,
2423  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2424  * the resultant file specification is placed.  If outbuf is NULL, the
2425  * resultant file specification is placed into a static buffer.
2426  * The third argument, if non-NULL, is taken to be a default file
2427  * specification string.  The fourth argument is unused at present.
2428  * rmesexpand() returns the address of the resultant string if
2429  * successful, and NULL on error.
2430  */
2431 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2432
2433 static char *
2434 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2435 {
2436   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2437   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2438   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2439   struct FAB myfab = cc$rms_fab;
2440   struct NAM mynam = cc$rms_nam;
2441   STRLEN speclen;
2442   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2443
2444   if (!filespec || !*filespec) {
2445     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2446     return NULL;
2447   }
2448   if (!outbuf) {
2449     if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2450     else    outbuf = __rmsexpand_retbuf;
2451   }
2452   if ((isunix = (strchr(filespec,'/') != NULL))) {
2453     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2454     filespec = vmsfspec;
2455   }
2456
2457   myfab.fab$l_fna = filespec;
2458   myfab.fab$b_fns = strlen(filespec);
2459   myfab.fab$l_nam = &mynam;
2460
2461   if (defspec && *defspec) {
2462     if (strchr(defspec,'/') != NULL) {
2463       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2464       defspec = tmpfspec;
2465     }
2466     myfab.fab$l_dna = defspec;
2467     myfab.fab$b_dns = strlen(defspec);
2468   }
2469
2470   mynam.nam$l_esa = esa;
2471   mynam.nam$b_ess = sizeof esa;
2472   mynam.nam$l_rsa = outbuf;
2473   mynam.nam$b_rss = NAM$C_MAXRSS;
2474
2475   retsts = sys$parse(&myfab,0,0);
2476   if (!(retsts & 1)) {
2477     mynam.nam$b_nop |= NAM$M_SYNCHK;
2478     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2479       retsts = sys$parse(&myfab,0,0);
2480       if (retsts & 1) goto expanded;
2481     }
2482     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2483     (void) sys$parse(&myfab,0,0);  /* Free search context */
2484     if (out) Safefree(out);
2485     set_vaxc_errno(retsts);
2486     if      (retsts == RMS$_PRV) set_errno(EACCES);
2487     else if (retsts == RMS$_DEV) set_errno(ENODEV);
2488     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2489     else                         set_errno(EVMSERR);
2490     return NULL;
2491   }
2492   retsts = sys$search(&myfab,0,0);
2493   if (!(retsts & 1) && retsts != RMS$_FNF) {
2494     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2495     myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
2496     if (out) Safefree(out);
2497     set_vaxc_errno(retsts);
2498     if      (retsts == RMS$_PRV) set_errno(EACCES);
2499     else                         set_errno(EVMSERR);
2500     return NULL;
2501   }
2502
2503   /* If the input filespec contained any lowercase characters,
2504    * downcase the result for compatibility with Unix-minded code. */
2505   expanded:
2506   for (out = myfab.fab$l_fna; *out; out++)
2507     if (islower(*out)) { haslower = 1; break; }
2508   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2509   else                 { out = esa;    speclen = mynam.nam$b_esl; }
2510   /* Trim off null fields added by $PARSE
2511    * If type > 1 char, must have been specified in original or default spec
2512    * (not true for version; $SEARCH may have added version of existing file).
2513    */
2514   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2515   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2516              (mynam.nam$l_ver - mynam.nam$l_type == 1);
2517   if (trimver || trimtype) {
2518     if (defspec && *defspec) {
2519       char defesa[NAM$C_MAXRSS];
2520       struct FAB deffab = cc$rms_fab;
2521       struct NAM defnam = cc$rms_nam;
2522
2523       deffab.fab$l_nam = &defnam;
2524       deffab.fab$l_fna = defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
2525       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
2526       defnam.nam$b_nop = NAM$M_SYNCHK;
2527       if (sys$parse(&deffab,0,0) & 1) {
2528         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2529         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2530       }
2531     }
2532     if (trimver) speclen = mynam.nam$l_ver - out;
2533     if (trimtype) {
2534       /* If we didn't already trim version, copy down */
2535       if (speclen > mynam.nam$l_ver - out)
2536         memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2537                speclen - (mynam.nam$l_ver - out));
2538       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2539     }
2540   }
2541   /* If we just had a directory spec on input, $PARSE "helpfully"
2542    * adds an empty name and type for us */
2543   if (mynam.nam$l_name == mynam.nam$l_type &&
2544       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
2545       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2546     speclen = mynam.nam$l_name - out;
2547   out[speclen] = '\0';
2548   if (haslower) __mystrtolower(out);
2549
2550   /* Have we been working with an expanded, but not resultant, spec? */
2551   /* Also, convert back to Unix syntax if necessary. */
2552   if (!mynam.nam$b_rsl) {
2553     if (isunix) {
2554       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2555     }
2556     else strcpy(outbuf,esa);
2557   }
2558   else if (isunix) {
2559     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2560     strcpy(outbuf,tmpfspec);
2561   }
2562   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2563   mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2564   myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
2565   return outbuf;
2566 }
2567 /*}}}*/
2568 /* External entry points */
2569 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2570 { return do_rmsexpand(spec,buf,0,def,opt); }
2571 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2572 { return do_rmsexpand(spec,buf,1,def,opt); }
2573
2574
2575 /*
2576 ** The following routines are provided to make life easier when
2577 ** converting among VMS-style and Unix-style directory specifications.
2578 ** All will take input specifications in either VMS or Unix syntax. On
2579 ** failure, all return NULL.  If successful, the routines listed below
2580 ** return a pointer to a buffer containing the appropriately
2581 ** reformatted spec (and, therefore, subsequent calls to that routine
2582 ** will clobber the result), while the routines of the same names with
2583 ** a _ts suffix appended will return a pointer to a mallocd string
2584 ** containing the appropriately reformatted spec.
2585 ** In all cases, only explicit syntax is altered; no check is made that
2586 ** the resulting string is valid or that the directory in question
2587 ** actually exists.
2588 **
2589 **   fileify_dirspec() - convert a directory spec into the name of the
2590 **     directory file (i.e. what you can stat() to see if it's a dir).
2591 **     The style (VMS or Unix) of the result is the same as the style
2592 **     of the parameter passed in.
2593 **   pathify_dirspec() - convert a directory spec into a path (i.e.
2594 **     what you prepend to a filename to indicate what directory it's in).
2595 **     The style (VMS or Unix) of the result is the same as the style
2596 **     of the parameter passed in.
2597 **   tounixpath() - convert a directory spec into a Unix-style path.
2598 **   tovmspath() - convert a directory spec into a VMS-style path.
2599 **   tounixspec() - convert any file spec into a Unix-style file spec.
2600 **   tovmsspec() - convert any file spec into a VMS-style spec.
2601 **
2602 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
2603 ** Permission is given to distribute this code as part of the Perl
2604 ** standard distribution under the terms of the GNU General Public
2605 ** License or the Perl Artistic License.  Copies of each may be
2606 ** found in the Perl standard distribution.
2607  */
2608
2609 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2610 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2611 {
2612     static char __fileify_retbuf[NAM$C_MAXRSS+1];
2613     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2614     char *retspec, *cp1, *cp2, *lastdir;
2615     char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2616
2617     if (!dir || !*dir) {
2618       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2619     }
2620     dirlen = strlen(dir);
2621     while (dirlen && dir[dirlen-1] == '/') --dirlen;
2622     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2623       strcpy(trndir,"/sys$disk/000000");
2624       dir = trndir;
2625       dirlen = 16;
2626     }
2627     if (dirlen > NAM$C_MAXRSS) {
2628       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2629     }
2630     if (!strpbrk(dir+1,"/]>:")) {
2631       strcpy(trndir,*dir == '/' ? dir + 1: dir);
2632       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2633       dir = trndir;
2634       dirlen = strlen(dir);
2635     }
2636     else {
2637       strncpy(trndir,dir,dirlen);
2638       trndir[dirlen] = '\0';
2639       dir = trndir;
2640     }
2641     /* If we were handed a rooted logical name or spec, treat it like a
2642      * simple directory, so that
2643      *    $ Define myroot dev:[dir.]
2644      *    ... do_fileify_dirspec("myroot",buf,1) ...
2645      * does something useful.
2646      */
2647     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2648       dir[--dirlen] = '\0';
2649       dir[dirlen-1] = ']';
2650     }
2651
2652     if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2653       /* If we've got an explicit filename, we can just shuffle the string. */
2654       if (*(cp1+1)) hasfilename = 1;
2655       /* Similarly, we can just back up a level if we've got multiple levels
2656          of explicit directories in a VMS spec which ends with directories. */
2657       else {
2658         for (cp2 = cp1; cp2 > dir; cp2--) {
2659           if (*cp2 == '.') {
2660             *cp2 = *cp1; *cp1 = '\0';
2661             hasfilename = 1;
2662             break;
2663           }
2664           if (*cp2 == '[' || *cp2 == '<') break;
2665         }
2666       }
2667     }
2668
2669     if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2670       if (dir[0] == '.') {
2671         if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2672           return do_fileify_dirspec("[]",buf,ts);
2673         else if (dir[1] == '.' &&
2674                  (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2675           return do_fileify_dirspec("[-]",buf,ts);
2676       }
2677       if (dirlen && dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
2678         dirlen -= 1;                 /* to last element */
2679         lastdir = strrchr(dir,'/');
2680       }
2681       else if ((cp1 = strstr(dir,"/.")) != NULL) {
2682         /* If we have "/." or "/..", VMSify it and let the VMS code
2683          * below expand it, rather than repeating the code to handle
2684          * relative components of a filespec here */
2685         do {
2686           if (*(cp1+2) == '.') cp1++;
2687           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2688             if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2689             if (strchr(vmsdir,'/') != NULL) {
2690               /* If do_tovmsspec() returned it, it must have VMS syntax
2691                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
2692                * the time to check this here only so we avoid a recursion
2693                * loop; otherwise, gigo.
2694                */
2695               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
2696             }
2697             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2698             return do_tounixspec(trndir,buf,ts);
2699           }
2700           cp1++;
2701         } while ((cp1 = strstr(cp1,"/.")) != NULL);
2702         lastdir = strrchr(dir,'/');
2703       }
2704       else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2705         /* Ditto for specs that end in an MFD -- let the VMS code
2706          * figure out whether it's a real device or a rooted logical. */
2707         dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2708         if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2709         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2710         return do_tounixspec(trndir,buf,ts);
2711       }
2712       else {
2713         if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2714              !(lastdir = cp1 = strrchr(dir,']')) &&
2715              !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2716         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
2717           int ver; char *cp3;
2718           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
2719               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
2720               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2721               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
2722               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2723                             (ver || *cp3)))))) {
2724             set_errno(ENOTDIR);
2725             set_vaxc_errno(RMS$_DIR);
2726             return NULL;
2727           }
2728           dirlen = cp2 - dir;
2729         }
2730       }
2731       /* If we lead off with a device or rooted logical, add the MFD
2732          if we're specifying a top-level directory. */
2733       if (lastdir && *dir == '/') {
2734         addmfd = 1;
2735         for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2736           if (*cp1 == '/') {
2737             addmfd = 0;
2738             break;
2739           }
2740         }
2741       }
2742       retlen = dirlen + (addmfd ? 13 : 6);
2743       if (buf) retspec = buf;
2744       else if (ts) New(1309,retspec,retlen+1,char);
2745       else retspec = __fileify_retbuf;
2746       if (addmfd) {
2747         dirlen = lastdir - dir;
2748         memcpy(retspec,dir,dirlen);
2749         strcpy(&retspec[dirlen],"/000000");
2750         strcpy(&retspec[dirlen+7],lastdir);
2751       }
2752       else {
2753         memcpy(retspec,dir,dirlen);
2754         retspec[dirlen] = '\0';
2755       }
2756       /* We've picked up everything up to the directory file name.
2757          Now just add the type and version, and we're set. */
2758       strcat(retspec,".dir;1");
2759       return retspec;
2760     }
2761     else {  /* VMS-style directory spec */
2762       char esa[NAM$C_MAXRSS+1], term, *cp;
2763       unsigned long int sts, cmplen, haslower = 0;
2764       struct FAB dirfab = cc$rms_fab;
2765       struct NAM savnam, dirnam = cc$rms_nam;
2766
2767       dirfab.fab$b_fns = strlen(dir);
2768       dirfab.fab$l_fna = dir;
2769       dirfab.fab$l_nam = &dirnam;
2770       dirfab.fab$l_dna = ".DIR;1";
2771       dirfab.fab$b_dns = 6;
2772       dirnam.nam$b_ess = NAM$C_MAXRSS;
2773       dirnam.nam$l_esa = esa;
2774
2775       for (cp = dir; *cp; cp++)
2776         if (islower(*cp)) { haslower = 1; break; }
2777       if (!((sts = sys$parse(&dirfab))&1)) {
2778         if (dirfab.fab$l_sts == RMS$_DIR) {
2779           dirnam.nam$b_nop |= NAM$M_SYNCHK;
2780           sts = sys$parse(&dirfab) & 1;
2781         }
2782         if (!sts) {
2783           set_errno(EVMSERR);
2784           set_vaxc_errno(dirfab.fab$l_sts);
2785           return NULL;
2786         }
2787       }
2788       else {
2789         savnam = dirnam;
2790         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
2791           /* Yes; fake the fnb bits so we'll check type below */
2792           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2793         }
2794         else { /* No; just work with potential name */
2795           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2796           else {
2797             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
2798             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2799             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2800             return NULL;
2801           }
2802         }
2803       }
2804       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2805         cp1 = strchr(esa,']');
2806         if (!cp1) cp1 = strchr(esa,'>');
2807         if (cp1) {  /* Should always be true */
2808           dirnam.nam$b_esl -= cp1 - esa - 1;
2809           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2810         }
2811       }
2812       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
2813         /* Yep; check version while we're at it, if it's there. */
2814         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2815         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2816           /* Something other than .DIR[;1].  Bzzt. */
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           set_errno(ENOTDIR);
2820           set_vaxc_errno(RMS$_DIR);
2821           return NULL;
2822         }
2823       }
2824       esa[dirnam.nam$b_esl] = '\0';
2825       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2826         /* They provided at least the name; we added the type, if necessary, */
2827         if (buf) retspec = buf;                            /* in sys$parse() */
2828         else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2829         else retspec = __fileify_retbuf;
2830         strcpy(retspec,esa);
2831         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2832         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2833         return retspec;
2834       }
2835       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2836         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2837         *cp1 = '\0';
2838         dirnam.nam$b_esl -= 9;
2839       }
2840       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2841       if (cp1 == NULL) { /* should never happen */
2842         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2843         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2844         return NULL;
2845       }
2846       term = *cp1;
2847       *cp1 = '\0';
2848       retlen = strlen(esa);
2849       if ((cp1 = strrchr(esa,'.')) != NULL) {
2850         /* There's more than one directory in the path.  Just roll back. */
2851         *cp1 = term;
2852         if (buf) retspec = buf;
2853         else if (ts) New(1311,retspec,retlen+7,char);
2854         else retspec = __fileify_retbuf;
2855         strcpy(retspec,esa);
2856       }
2857       else {
2858         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2859           /* Go back and expand rooted logical name */
2860           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2861           if (!(sys$parse(&dirfab) & 1)) {
2862             dirnam.nam$l_rlf = NULL;
2863             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2864             set_errno(EVMSERR);
2865             set_vaxc_errno(dirfab.fab$l_sts);
2866             return NULL;
2867           }
2868           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2869           if (buf) retspec = buf;
2870           else if (ts) New(1312,retspec,retlen+16,char);
2871           else retspec = __fileify_retbuf;
2872           cp1 = strstr(esa,"][");
2873           dirlen = cp1 - esa;
2874           memcpy(retspec,esa,dirlen);
2875           if (!strncmp(cp1+2,"000000]",7)) {
2876             retspec[dirlen-1] = '\0';
2877             for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2878             if (*cp1 == '.') *cp1 = ']';
2879             else {
2880               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2881               memcpy(cp1+1,"000000]",7);
2882             }
2883           }
2884           else {
2885             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
2886             retspec[retlen] = '\0';
2887             /* Convert last '.' to ']' */
2888             for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2889             if (*cp1 == '.') *cp1 = ']';
2890             else {
2891               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2892               memcpy(cp1+1,"000000]",7);
2893             }
2894           }
2895         }
2896         else {  /* This is a top-level dir.  Add the MFD to the path. */
2897           if (buf) retspec = buf;
2898           else if (ts) New(1312,retspec,retlen+16,char);
2899           else retspec = __fileify_retbuf;
2900           cp1 = esa;
2901           cp2 = retspec;
2902           while (*cp1 != ':') *(cp2++) = *(cp1++);
2903           strcpy(cp2,":[000000]");
2904           cp1 += 2;
2905           strcpy(cp2+9,cp1);
2906         }
2907       }
2908       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2909       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2910       /* We've set up the string up through the filename.  Add the
2911          type and version, and we're done. */
2912       strcat(retspec,".DIR;1");
2913
2914       /* $PARSE may have upcased filespec, so convert output to lower
2915        * case if input contained any lowercase characters. */
2916       if (haslower) __mystrtolower(retspec);
2917       return retspec;
2918     }
2919 }  /* end of do_fileify_dirspec() */
2920 /*}}}*/
2921 /* External entry points */
2922 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
2923 { return do_fileify_dirspec(dir,buf,0); }
2924 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
2925 { return do_fileify_dirspec(dir,buf,1); }
2926
2927 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
2928 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
2929 {
2930     static char __pathify_retbuf[NAM$C_MAXRSS+1];
2931     unsigned long int retlen;
2932     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
2933
2934     if (!dir || !*dir) {
2935       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2936     }
2937
2938     if (*dir) strcpy(trndir,dir);
2939     else getcwd(trndir,sizeof trndir - 1);
2940
2941     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
2942            && my_trnlnm(trndir,trndir,0)) {
2943       STRLEN trnlen = strlen(trndir);
2944
2945       /* Trap simple rooted lnms, and return lnm:[000000] */
2946       if (!strcmp(trndir+trnlen-2,".]")) {
2947         if (buf) retpath = buf;
2948         else if (ts) New(1318,retpath,strlen(dir)+10,char);
2949         else retpath = __pathify_retbuf;
2950         strcpy(retpath,dir);
2951         strcat(retpath,":[000000]");
2952         return retpath;
2953       }
2954     }
2955     dir = trndir;
2956
2957     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
2958       if (*dir == '.' && (*(dir+1) == '\0' ||
2959                           (*(dir+1) == '.' && *(dir+2) == '\0')))
2960         retlen = 2 + (*(dir+1) != '\0');
2961       else {
2962         if ( !(cp1 = strrchr(dir,'/')) &&
2963              !(cp1 = strrchr(dir,']')) &&
2964              !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
2965         if ((cp2 = strchr(cp1,'.')) != NULL &&
2966             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
2967              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
2968               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
2969               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
2970           int ver; char *cp3;
2971           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
2972               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
2973               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2974               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
2975               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2976                             (ver || *cp3)))))) {
2977             set_errno(ENOTDIR);
2978             set_vaxc_errno(RMS$_DIR);
2979             return NULL;
2980           }
2981           retlen = cp2 - dir + 1;
2982         }
2983         else {  /* No file type present.  Treat the filename as a directory. */
2984           retlen = strlen(dir) + 1;
2985         }
2986       }
2987       if (buf) retpath = buf;
2988       else if (ts) New(1313,retpath,retlen+1,char);
2989       else retpath = __pathify_retbuf;
2990       strncpy(retpath,dir,retlen-1);
2991       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
2992         retpath[retlen-1] = '/';      /* with '/', add it. */
2993         retpath[retlen] = '\0';
2994       }
2995       else retpath[retlen-1] = '\0';
2996     }
2997     else {  /* VMS-style directory spec */
2998       char esa[NAM$C_MAXRSS+1], *cp;
2999       unsigned long int sts, cmplen, haslower;
3000       struct FAB dirfab = cc$rms_fab;
3001       struct NAM savnam, dirnam = cc$rms_nam;
3002
3003       /* If we've got an explicit filename, we can just shuffle the string. */
3004       if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3005              (cp1 = strrchr(dir,'>')) != NULL     ) && *(cp1+1)) {
3006         if ((cp2 = strchr(cp1,'.')) != NULL) {
3007           int ver; char *cp3;
3008           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3009               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3010               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3011               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3012               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3013                             (ver || *cp3)))))) {
3014             set_errno(ENOTDIR);
3015             set_vaxc_errno(RMS$_DIR);
3016             return NULL;
3017           }
3018         }
3019         else {  /* No file type, so just draw name into directory part */
3020           for (cp2 = cp1; *cp2; cp2++) ;
3021         }
3022         *cp2 = *cp1;
3023         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
3024         *cp1 = '.';
3025         /* We've now got a VMS 'path'; fall through */
3026       }
3027       dirfab.fab$b_fns = strlen(dir);
3028       dirfab.fab$l_fna = dir;
3029       if (dir[dirfab.fab$b_fns-1] == ']' ||
3030           dir[dirfab.fab$b_fns-1] == '>' ||
3031           dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3032         if (buf) retpath = buf;
3033         else if (ts) New(1314,retpath,strlen(dir)+1,char);
3034         else retpath = __pathify_retbuf;
3035         strcpy(retpath,dir);
3036         return retpath;
3037       }
3038       dirfab.fab$l_dna = ".DIR;1";
3039       dirfab.fab$b_dns = 6;
3040       dirfab.fab$l_nam = &dirnam;
3041       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3042       dirnam.nam$l_esa = esa;
3043
3044       for (cp = dir; *cp; cp++)
3045         if (islower(*cp)) { haslower = 1; break; }
3046
3047       if (!(sts = (sys$parse(&dirfab)&1))) {
3048         if (dirfab.fab$l_sts == RMS$_DIR) {
3049           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3050           sts = sys$parse(&dirfab) & 1;
3051         }
3052         if (!sts) {
3053           set_errno(EVMSERR);
3054           set_vaxc_errno(dirfab.fab$l_sts);
3055           return NULL;
3056         }
3057       }
3058       else {
3059         savnam = dirnam;
3060         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
3061           if (dirfab.fab$l_sts != RMS$_FNF) {
3062             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3063             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3064             set_errno(EVMSERR);
3065             set_vaxc_errno(dirfab.fab$l_sts);
3066             return NULL;
3067           }
3068           dirnam = savnam; /* No; just work with potential name */
3069         }
3070       }
3071       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3072         /* Yep; check version while we're at it, if it's there. */
3073         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3074         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3075           /* Something other than .DIR[;1].  Bzzt. */
3076           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3077           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3078           set_errno(ENOTDIR);
3079           set_vaxc_errno(RMS$_DIR);
3080           return NULL;
3081         }
3082       }
3083       /* OK, the type was fine.  Now pull any file name into the
3084          directory path. */
3085       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3086       else {
3087         cp1 = strrchr(esa,'>');
3088         *dirnam.nam$l_type = '>';
3089       }
3090       *cp1 = '.';
3091       *(dirnam.nam$l_type + 1) = '\0';
3092       retlen = dirnam.nam$l_type - esa + 2;
3093       if (buf) retpath = buf;
3094       else if (ts) New(1314,retpath,retlen,char);
3095       else retpath = __pathify_retbuf;
3096       strcpy(retpath,esa);
3097       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3098       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3099       /* $PARSE may have upcased filespec, so convert output to lower
3100        * case if input contained any lowercase characters. */
3101       if (haslower) __mystrtolower(retpath);
3102     }
3103
3104     return retpath;
3105 }  /* end of do_pathify_dirspec() */
3106 /*}}}*/
3107 /* External entry points */
3108 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3109 { return do_pathify_dirspec(dir,buf,0); }
3110 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3111 { return do_pathify_dirspec(dir,buf,1); }
3112
3113 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3114 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3115 {
3116   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3117   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3118   int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3119
3120   if (spec == NULL) return NULL;
3121   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3122   if (buf) rslt = buf;
3123   else if (ts) {
3124     retlen = strlen(spec);
3125     cp1 = strchr(spec,'[');
3126     if (!cp1) cp1 = strchr(spec,'<');
3127     if (cp1) {
3128       for (cp1++; *cp1; cp1++) {
3129         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
3130         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3131           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3132       }
3133     }
3134     New(1315,rslt,retlen+2+2*expand,char);
3135   }
3136   else rslt = __tounixspec_retbuf;
3137   if (strchr(spec,'/') != NULL) {
3138     strcpy(rslt,spec);
3139     return rslt;
3140   }
3141
3142   cp1 = rslt;
3143   cp2 = spec;
3144   dirend = strrchr(spec,']');
3145   if (dirend == NULL) dirend = strrchr(spec,'>');
3146   if (dirend == NULL) dirend = strchr(spec,':');
3147   if (dirend == NULL) {
3148     strcpy(rslt,spec);
3149     return rslt;
3150   }
3151   if (*cp2 != '[' && *cp2 != '<') {
3152     *(cp1++) = '/';
3153   }
3154   else {  /* the VMS spec begins with directories */
3155     cp2++;
3156     if (*cp2 == ']' || *cp2 == '>') {
3157       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3158       return rslt;
3159     }
3160     else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3161       if (getcwd(tmp,sizeof tmp,1) == NULL) {
3162         if (ts) Safefree(rslt);
3163         return NULL;
3164       }
3165       do {
3166         cp3 = tmp;
3167         while (*cp3 != ':' && *cp3) cp3++;
3168         *(cp3++) = '\0';
3169         if (strchr(cp3,']') != NULL) break;
3170       } while (vmstrnenv(tmp,tmp,0,fildev,0));
3171       if (ts && !buf &&
3172           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3173         retlen = devlen + dirlen;
3174         Renew(rslt,retlen+1+2*expand,char);
3175         cp1 = rslt;
3176       }
3177       cp3 = tmp;
3178       *(cp1++) = '/';
3179       while (*cp3) {
3180         *(cp1++) = *(cp3++);
3181         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3182       }
3183       *(cp1++) = '/';
3184     }
3185     else if ( *cp2 == '.') {
3186       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3187         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3188         cp2 += 3;
3189       }
3190       else cp2++;
3191     }
3192   }
3193   for (; cp2 <= dirend; cp2++) {
3194     if (*cp2 == ':') {
3195       *(cp1++) = '/';
3196       if (*(cp2+1) == '[') cp2++;
3197     }
3198     else if (*cp2 == ']' || *cp2 == '>') {
3199       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3200     }
3201     else if (*cp2 == '.') {
3202       *(cp1++) = '/';
3203       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3204         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3205                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3206         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3207             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3208       }
3209       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3210         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3211         cp2 += 2;
3212       }
3213     }
3214     else if (*cp2 == '-') {
3215       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3216         while (*cp2 == '-') {
3217           cp2++;
3218           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3219         }
3220         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3221           if (ts) Safefree(rslt);                        /* filespecs like */
3222           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
3223           return NULL;
3224         }
3225       }
3226       else *(cp1++) = *cp2;
3227     }
3228     else *(cp1++) = *cp2;
3229   }
3230   while (*cp2) *(cp1++) = *(cp2++);
3231   *cp1 = '\0';
3232
3233   return rslt;
3234
3235 }  /* end of do_tounixspec() */
3236 /*}}}*/
3237 /* External entry points */
3238 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3239 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3240
3241 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3242 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3243   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3244   char *rslt, *dirend;
3245   register char *cp1, *cp2;
3246   unsigned long int infront = 0, hasdir = 1;
3247
3248   if (path == NULL) return NULL;
3249   if (buf) rslt = buf;
3250   else if (ts) New(1316,rslt,strlen(path)+9,char);
3251   else rslt = __tovmsspec_retbuf;
3252   if (strpbrk(path,"]:>") ||
3253       (dirend = strrchr(path,'/')) == NULL) {
3254     if (path[0] == '.') {
3255       if (path[1] == '\0') strcpy(rslt,"[]");
3256       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3257       else strcpy(rslt,path); /* probably garbage */
3258     }
3259     else strcpy(rslt,path);
3260     return rslt;
3261   }
3262   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
3263     if (!*(dirend+2)) dirend +=2;
3264     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3265     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3266   }
3267   cp1 = rslt;
3268   cp2 = path;
3269   if (*cp2 == '/') {
3270     char trndev[NAM$C_MAXRSS+1];
3271     int islnm, rooted;
3272     STRLEN trnend;
3273
3274     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
3275     if (!*(cp2+1)) {
3276       if (!buf & ts) Renew(rslt,18,char);
3277       strcpy(rslt,"sys$disk:[000000]");
3278       return rslt;
3279     }
3280     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3281     *cp1 = '\0';
3282     islnm =  my_trnlnm(rslt,trndev,0);
3283     trnend = islnm ? strlen(trndev) - 1 : 0;
3284     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3285     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3286     /* If the first element of the path is a logical name, determine
3287      * whether it has to be translated so we can add more directories. */
3288     if (!islnm || rooted) {
3289       *(cp1++) = ':';
3290       *(cp1++) = '[';
3291       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3292       else cp2++;
3293     }
3294     else {
3295       if (cp2 != dirend) {
3296         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3297         strcpy(rslt,trndev);
3298         cp1 = rslt + trnend;
3299         *(cp1++) = '.';
3300         cp2++;
3301       }
3302       else {
3303         *(cp1++) = ':';
3304         hasdir = 0;
3305       }
3306     }
3307   }
3308   else {
3309     *(cp1++) = '[';
3310     if (*cp2 == '.') {
3311       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3312         cp2 += 2;         /* skip over "./" - it's redundant */
3313         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
3314       }
3315       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3316         *(cp1++) = '-';                                 /* "../" --> "-" */
3317         cp2 += 3;
3318       }
3319       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3320                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3321         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3322         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3323         cp2 += 4;
3324       }
3325       if (cp2 > dirend) cp2 = dirend;
3326     }
3327     else *(cp1++) = '.';
3328   }
3329   for (; cp2 < dirend; cp2++) {
3330     if (*cp2 == '/') {
3331       if (*(cp2-1) == '/') continue;
3332       if (*(cp1-1) != '.') *(cp1++) = '.';
3333       infront = 0;
3334     }
3335     else if (!infront && *cp2 == '.') {
3336       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3337       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
3338       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3339         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3340         else if (*(cp1-2) == '[') *(cp1-1) = '-';
3341         else {  /* back up over previous directory name */
3342           cp1--;
3343           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3344           if (*(cp1-1) == '[') {
3345             memcpy(cp1,"000000.",7);
3346             cp1 += 7;
3347           }
3348         }
3349         cp2 += 2;
3350         if (cp2 == dirend) break;
3351       }
3352       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3353                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3354         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3355         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3356         if (!*(cp2+3)) {
3357           *(cp1++) = '.';  /* Simulate trailing '/' */
3358           cp2 += 2;  /* for loop will incr this to == dirend */
3359         }
3360         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
3361       }
3362       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
3363     }
3364     else {
3365       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
3366       if (*cp2 == '.')      *(cp1++) = '_';
3367       else                  *(cp1++) =  *cp2;
3368       infront = 1;
3369     }
3370   }
3371   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3372   if (hasdir) *(cp1++) = ']';
3373   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
3374   while (*cp2) *(cp1++) = *(cp2++);
3375   *cp1 = '\0';
3376
3377   return rslt;
3378
3379 }  /* end of do_tovmsspec() */
3380 /*}}}*/
3381 /* External entry points */
3382 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3383 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3384
3385 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3386 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3387   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3388   int vmslen;
3389   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3390
3391   if (path == NULL) return NULL;
3392   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3393   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3394   if (buf) return buf;
3395   else if (ts) {
3396     vmslen = strlen(vmsified);
3397     New(1317,cp,vmslen+1,char);
3398     memcpy(cp,vmsified,vmslen);
3399     cp[vmslen] = '\0';
3400     return cp;
3401   }
3402   else {
3403     strcpy(__tovmspath_retbuf,vmsified);
3404     return __tovmspath_retbuf;
3405   }
3406
3407 }  /* end of do_tovmspath() */
3408 /*}}}*/
3409 /* External entry points */
3410 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3411 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3412
3413
3414 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3415 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3416   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3417   int unixlen;
3418   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3419
3420   if (path == NULL) return NULL;
3421   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3422   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3423   if (buf) return buf;
3424   else if (ts) {
3425     unixlen = strlen(unixified);
3426     New(1317,cp,unixlen+1,char);
3427     memcpy(cp,unixified,unixlen);
3428     cp[unixlen] = '\0';
3429     return cp;
3430   }
3431   else {
3432     strcpy(__tounixpath_retbuf,unixified);
3433     return __tounixpath_retbuf;
3434   }
3435
3436 }  /* end of do_tounixpath() */
3437 /*}}}*/
3438 /* External entry points */
3439 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3440 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3441
3442 /*
3443  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
3444  *
3445  *****************************************************************************
3446  *                                                                           *
3447  *  Copyright (C) 1989-1994 by                                               *
3448  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
3449  *                                                                           *
3450  *  Permission is hereby  granted for the reproduction of this software,     *
3451  *  on condition that this copyright notice is included in the reproduction, *
3452  *  and that such reproduction is not for purposes of profit or material     *
3453  *  gain.                                                                    *
3454  *                                                                           *
3455  *  27-Aug-1994 Modified for inclusion in perl5                              *
3456  *              by Charles Bailey  bailey@newman.upenn.edu                   *
3457  *****************************************************************************
3458  */
3459
3460 /*
3461  * getredirection() is intended to aid in porting C programs
3462  * to VMS (Vax-11 C).  The native VMS environment does not support
3463  * '>' and '<' I/O redirection, or command line wild card expansion,
3464  * or a command line pipe mechanism using the '|' AND background
3465  * command execution '&'.  All of these capabilities are provided to any
3466  * C program which calls this procedure as the first thing in the
3467  * main program.
3468  * The piping mechanism will probably work with almost any 'filter' type
3469  * of program.  With suitable modification, it may useful for other
3470  * portability problems as well.
3471  *
3472  * Author:  Mark Pizzolato      mark@infocomm.com
3473  */
3474 struct list_item
3475     {
3476     struct list_item *next;
3477     char *value;
3478     };
3479
3480 static void add_item(struct list_item **head,
3481                      struct list_item **tail,
3482                      char *value,
3483                      int *count);
3484
3485 static void mp_expand_wild_cards(pTHX_ char *item,
3486                                 struct list_item **head,
3487                                 struct list_item **tail,
3488                                 int *count);
3489
3490 static int background_process(int argc, char **argv);
3491
3492 static void pipe_and_fork(pTHX_ char **cmargv);
3493
3494 /*{{{ void getredirection(int *ac, char ***av)*/
3495 static void
3496 mp_getredirection(pTHX_ int *ac, char ***av)
3497 /*
3498  * Process vms redirection arg's.  Exit if any error is seen.
3499  * If getredirection() processes an argument, it is erased
3500  * from the vector.  getredirection() returns a new argc and argv value.
3501  * In the event that a background command is requested (by a trailing "&"),
3502  * this routine creates a background subprocess, and simply exits the program.
3503  *
3504  * Warning: do not try to simplify the code for vms.  The code
3505  * presupposes that getredirection() is called before any data is
3506  * read from stdin or written to stdout.
3507  *
3508  * Normal usage is as follows:
3509  *
3510  *      main(argc, argv)
3511  *      int             argc;
3512  *      char            *argv[];
3513  *      {
3514  *              getredirection(&argc, &argv);
3515  *      }
3516  */
3517 {
3518     int                 argc = *ac;     /* Argument Count         */
3519     char                **argv = *av;   /* Argument Vector        */
3520     char                *ap;            /* Argument pointer       */
3521     int                 j;              /* argv[] index           */
3522     int                 item_count = 0; /* Count of Items in List */
3523     struct list_item    *list_head = 0; /* First Item in List       */
3524     struct list_item    *list_tail;     /* Last Item in List        */
3525     char                *in = NULL;     /* Input File Name          */
3526     char                *out = NULL;    /* Output File Name         */
3527     char                *outmode = "w"; /* Mode to Open Output File */
3528     char                *err = NULL;    /* Error File Name          */
3529     char                *errmode = "w"; /* Mode to Open Error File  */
3530     int                 cmargc = 0;     /* Piped Command Arg Count  */
3531     char                **cmargv = NULL;/* Piped Command Arg Vector */
3532
3533     /*
3534      * First handle the case where the last thing on the line ends with
3535      * a '&'.  This indicates the desire for the command to be run in a
3536      * subprocess, so we satisfy that desire.
3537      */
3538     ap = argv[argc-1];
3539     if (0 == strcmp("&", ap))
3540         exit(background_process(--argc, argv));
3541     if (*ap && '&' == ap[strlen(ap)-1])
3542         {
3543         ap[strlen(ap)-1] = '\0';
3544         exit(background_process(argc, argv));
3545         }
3546     /*
3547      * Now we handle the general redirection cases that involve '>', '>>',
3548      * '<', and pipes '|'.
3549      */
3550     for (j = 0; j < argc; ++j)
3551         {
3552         if (0 == strcmp("<", argv[j]))
3553             {
3554             if (j+1 >= argc)
3555                 {
3556                 fprintf(stderr,"No input file after < on command line");
3557                 exit(LIB$_WRONUMARG);
3558                 }
3559             in = argv[++j];
3560             continue;
3561             }
3562         if ('<' == *(ap = argv[j]))
3563             {
3564             in = 1 + ap;
3565             continue;
3566             }
3567         if (0 == strcmp(">", ap))
3568             {
3569             if (j+1 >= argc)
3570                 {
3571                 fprintf(stderr,"No output file after > on command line");
3572                 exit(LIB$_WRONUMARG);
3573                 }
3574             out = argv[++j];
3575             continue;
3576             }
3577         if ('>' == *ap)
3578             {
3579             if ('>' == ap[1])
3580                 {
3581                 outmode = "a";
3582                 if ('\0' == ap[2])
3583                     out = argv[++j];
3584                 else
3585                     out = 2 + ap;
3586                 }
3587             else
3588                 out = 1 + ap;
3589             if (j >= argc)
3590                 {
3591                 fprintf(stderr,"No output file after > or >> on command line");
3592                 exit(LIB$_WRONUMARG);
3593                 }
3594             continue;
3595             }
3596         if (('2' == *ap) && ('>' == ap[1]))
3597             {
3598             if ('>' == ap[2])
3599                 {
3600                 errmode = "a";
3601                 if ('\0' == ap[3])
3602                     err = argv[++j];
3603                 else
3604                     err = 3 + ap;
3605                 }
3606             else
3607                 if ('\0' == ap[2])
3608                     err = argv[++j];
3609                 else
3610                     err = 2 + ap;
3611             if (j >= argc)
3612                 {
3613                 fprintf(stderr,"No output file after 2> or 2>> on command line");
3614                 exit(LIB$_WRONUMARG);
3615                 }
3616             continue;
3617             }
3618         if (0 == strcmp("|", argv[j]))
3619             {
3620             if (j+1 >= argc)
3621                 {
3622                 fprintf(stderr,"No command into which to pipe on command line");
3623                 exit(LIB$_WRONUMARG);
3624                 }
3625             cmargc = argc-(j+1);
3626             cmargv = &argv[j+1];
3627             argc = j;
3628             continue;
3629             }
3630         if ('|' == *(ap = argv[j]))
3631             {
3632             ++argv[j];
3633             cmargc = argc-j;
3634             cmargv = &argv[j];
3635             argc = j;
3636             continue;
3637             }
3638         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3639         }
3640     /*
3641      * Allocate and fill in the new argument vector, Some Unix's terminate
3642      * the list with an extra null pointer.
3643      */
3644     New(1302, argv, item_count+1, char *);
3645     *av = argv;
3646     for (j = 0; j < item_count; ++j, list_head = list_head->next)
3647         argv[j] = list_head->value;
3648     *ac = item_count;
3649     if (cmargv != NULL)
3650         {
3651         if (out != NULL)
3652             {
3653             fprintf(stderr,"'|' and '>' may not both be specified on command line");
3654             exit(LIB$_INVARGORD);
3655             }
3656         pipe_and_fork(aTHX_ cmargv);
3657         }
3658
3659     /* Check for input from a pipe (mailbox) */
3660
3661     if (in == NULL && 1 == isapipe(0))
3662         {
3663         char mbxname[L_tmpnam];
3664         long int bufsize;
3665         long int dvi_item = DVI$_DEVBUFSIZ;
3666         $DESCRIPTOR(mbxnam, "");
3667         $DESCRIPTOR(mbxdevnam, "");
3668
3669         /* Input from a pipe, reopen it in binary mode to disable       */
3670         /* carriage control processing.                                 */
3671
3672         fgetname(stdin, mbxname);
3673         mbxnam.dsc$a_pointer = mbxname;
3674         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3675         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3676         mbxdevnam.dsc$a_pointer = mbxname;
3677         mbxdevnam.dsc$w_length = sizeof(mbxname);
3678         dvi_item = DVI$_DEVNAM;
3679         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3680         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3681         set_errno(0);
3682         set_vaxc_errno(1);
3683         freopen(mbxname, "rb", stdin);
3684         if (errno != 0)
3685             {
3686             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3687             exit(vaxc$errno);
3688             }
3689         }
3690     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3691         {
3692         fprintf(stderr,"Can't open input file %s as stdin",in);
3693         exit(vaxc$errno);
3694         }
3695     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3696         {
3697         fprintf(stderr,"Can't open output file %s as stdout",out);
3698         exit(vaxc$errno);
3699         }
3700         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
3701
3702     if (err != NULL) {
3703         if (strcmp(err,"&1") == 0) {
3704             dup2(fileno(stdout), fileno(stderr));
3705             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
3706         } else {
3707         FILE *tmperr;
3708         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3709             {
3710             fprintf(stderr,"Can't open error file %s as stderr",err);
3711             exit(vaxc$errno);
3712             }
3713             fclose(tmperr);
3714            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
3715                 {
3716                 exit(vaxc$errno);
3717                 }
3718             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
3719         }
3720         }
3721 #ifdef ARGPROC_DEBUG
3722     PerlIO_printf(Perl_debug_log, "Arglist:\n");
3723     for (j = 0; j < *ac;  ++j)
3724         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3725 #endif
3726    /* Clear errors we may have hit expanding wildcards, so they don't
3727       show up in Perl's $! later */
3728    set_errno(0); set_vaxc_errno(1);
3729 }  /* end of getredirection() */
3730 /*}}}*/
3731
3732 static void add_item(struct list_item **head,
3733                      struct list_item **tail,
3734                      char *value,
3735                      int *count)
3736 {
3737     if (*head == 0)
3738         {
3739         New(1303,*head,1,struct list_item);
3740         *tail = *head;
3741         }
3742     else {
3743         New(1304,(*tail)->next,1,struct list_item);
3744         *tail = (*tail)->next;
3745         }
3746     (*tail)->value = value;
3747     ++(*count);
3748 }
3749
3750 static void mp_expand_wild_cards(pTHX_ char *item,
3751                               struct list_item **head,
3752                               struct list_item **tail,
3753                               int *count)
3754 {
3755 int expcount = 0;
3756 unsigned long int context = 0;
3757 int isunix = 0;
3758 char *had_version;
3759 char *had_device;
3760 int had_directory;
3761 char *devdir,*cp;
3762 char vmsspec[NAM$C_MAXRSS+1];
3763 $DESCRIPTOR(filespec, "");
3764 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3765 $DESCRIPTOR(resultspec, "");
3766 unsigned long int zero = 0, sts;
3767
3768     for (cp = item; *cp; cp++) {
3769         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3770         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3771     }
3772     if (!*cp || isspace(*cp))
3773         {
3774         add_item(head, tail, item, count);
3775         return;
3776         }
3777     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3778     resultspec.dsc$b_class = DSC$K_CLASS_D;
3779     resultspec.dsc$a_pointer = NULL;
3780     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3781       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3782     if (!isunix || !filespec.dsc$a_pointer)
3783       filespec.dsc$a_pointer = item;
3784     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3785     /*
3786      * Only return version specs, if the caller specified a version
3787      */
3788     had_version = strchr(item, ';');
3789     /*
3790      * Only return device and directory specs, if the caller specifed either.
3791      */
3792     had_device = strchr(item, ':');
3793     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3794
3795     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3796                                   &defaultspec, 0, 0, &zero))))
3797         {
3798         char *string;
3799         char *c;
3800
3801         New(1305,string,resultspec.dsc$w_length+1,char);
3802         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3803         string[resultspec.dsc$w_length] = '\0';
3804         if (NULL == had_version)
3805             *((char *)strrchr(string, ';')) = '\0';
3806         if ((!had_directory) && (had_device == NULL))
3807             {
3808             if (NULL == (devdir = strrchr(string, ']')))
3809                 devdir = strrchr(string, '>');
3810             strcpy(string, devdir + 1);
3811             }
3812         /*
3813          * Be consistent with what the C RTL has already done to the rest of
3814          * the argv items and lowercase all of these names.
3815          */
3816         for (c = string; *c; ++c)
3817             if (isupper(*c))
3818                 *c = tolower(*c);
3819         if (isunix) trim_unixpath(string,item,1);
3820         add_item(head, tail, string, count);
3821         ++expcount;
3822         }
3823     if (sts != RMS$_NMF)
3824         {
3825         set_vaxc_errno(sts);
3826         switch (sts)
3827             {
3828             case RMS$_FNF: case RMS$_DNF:
3829                 set_errno(ENOENT); break;
3830             case RMS$_DIR:
3831                 set_errno(ENOTDIR); break;
3832             case RMS$_DEV:
3833                 set_errno(ENODEV); break;
3834             case RMS$_FNM: case RMS$_SYN:
3835                 set_errno(EINVAL); break;
3836             case RMS$_PRV:
3837                 set_errno(EACCES); break;
3838             default:
3839                 _ckvmssts_noperl(sts);
3840             }
3841         }
3842     if (expcount == 0)
3843         add_item(head, tail, item, count);
3844     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3845     _ckvmssts_noperl(lib$find_file_end(&context));
3846 }
3847
3848 static int child_st[2];/* Event Flag set when child process completes   */
3849
3850 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
3851
3852 static unsigned long int exit_handler(int *status)
3853 {
3854 short iosb[4];
3855
3856     if (0 == child_st[0])
3857         {
3858 #ifdef ARGPROC_DEBUG
3859         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3860 #endif
3861         fflush(stdout);     /* Have to flush pipe for binary data to    */
3862                             /* terminate properly -- <tp@mccall.com>    */
3863         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3864         sys$dassgn(child_chan);
3865         fclose(stdout);
3866         sys$synch(0, child_st);
3867         }
3868     return(1);
3869 }
3870
3871 static void sig_child(int chan)
3872 {
3873 #ifdef ARGPROC_DEBUG
3874     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
3875 #endif
3876     if (child_st[0] == 0)
3877         child_st[0] = 1;
3878 }
3879
3880 static struct exit_control_block exit_block =
3881     {
3882     0,
3883     exit_handler,
3884     1,
3885     &exit_block.exit_status,
3886     0
3887     };
3888
3889 static void pipe_and_fork(pTHX_ char **cmargv)
3890 {
3891     char subcmd[2048];
3892     $DESCRIPTOR(cmddsc, "");
3893     static char mbxname[64];
3894     $DESCRIPTOR(mbxdsc, mbxname);
3895     int pid, j;
3896     unsigned long int zero = 0, one = 1;
3897
3898     strcpy(subcmd, cmargv[0]);
3899     for (j = 1; NULL != cmargv[j]; ++j)
3900         {
3901         strcat(subcmd, " \"");
3902         strcat(subcmd, cmargv[j]);
3903         strcat(subcmd, "\"");
3904         }
3905     cmddsc.dsc$a_pointer = subcmd;
3906     cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
3907
3908         create_mbx(aTHX_ &child_chan,&mbxdsc);
3909 #ifdef ARGPROC_DEBUG
3910     PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
3911     PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
3912 #endif
3913     _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
3914                                0, &pid, child_st, &zero, sig_child,
3915                                &child_chan));
3916 #ifdef ARGPROC_DEBUG
3917     PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
3918 #endif
3919     sys$dclexh(&exit_block);
3920     if (NULL == freopen(mbxname, "wb", stdout))
3921         {
3922         PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
3923         }
3924 }
3925
3926 static int background_process(int argc, char **argv)
3927 {
3928 char command[2048] = "$";
3929 $DESCRIPTOR(value, "");
3930 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
3931 static $DESCRIPTOR(null, "NLA0:");
3932 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
3933 char pidstring[80];
3934 $DESCRIPTOR(pidstr, "");
3935 int pid;
3936 unsigned long int flags = 17, one = 1, retsts;
3937
3938     strcat(command, argv[0]);
3939     while (--argc)
3940         {
3941         strcat(command, " \"");
3942         strcat(command, *(++argv));
3943         strcat(command, "\"");
3944         }
3945     value.dsc$a_pointer = command;
3946     value.dsc$w_length = strlen(value.dsc$a_pointer);
3947     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
3948     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
3949     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
3950         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
3951     }
3952     else {
3953         _ckvmssts_noperl(retsts);
3954     }
3955 #ifdef ARGPROC_DEBUG
3956     PerlIO_printf(Perl_debug_log, "%s\n", command);
3957 #endif
3958     sprintf(pidstring, "%08X", pid);
3959     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
3960     pidstr.dsc$a_pointer = pidstring;
3961     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
3962     lib$set_symbol(&pidsymbol, &pidstr);
3963     return(SS$_NORMAL);
3964 }
3965 /*}}}*/
3966 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
3967
3968
3969 /* OS-specific initialization at image activation (not thread startup) */
3970 /* Older VAXC header files lack these constants */
3971 #ifndef JPI$_RIGHTS_SIZE
3972 #  define JPI$_RIGHTS_SIZE 817
3973 #endif
3974 #ifndef KGB$M_SUBSYSTEM
3975 #  define KGB$M_SUBSYSTEM 0x8
3976 #endif
3977
3978 /*{{{void vms_image_init(int *, char ***)*/
3979 void
3980 vms_image_init(int *argcp, char ***argvp)
3981 {
3982   char eqv[LNM$C_NAMLENGTH+1] = "";
3983   unsigned int len, tabct = 8, tabidx = 0;
3984   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
3985   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
3986   unsigned short int dummy, rlen;
3987   struct dsc$descriptor_s **tabvec;
3988 #if defined(PERL_IMPLICIT_CONTEXT)
3989   pTHX = NULL;
3990 #endif
3991   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
3992                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
3993                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
3994                                  {          0,                0,    0,      0} };
3995
3996   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
3997   _ckvmssts_noperl(iosb[0]);
3998   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
3999     if (iprv[i]) {           /* Running image installed with privs? */
4000       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
4001       will_taint = TRUE;
4002       break;
4003     }
4004   }
4005   /* Rights identifiers might trigger tainting as well. */
4006   if (!will_taint && (rlen || rsz)) {
4007     while (rlen < rsz) {
4008       /* We didn't get all the identifiers on the first pass.  Allocate a
4009        * buffer much larger than $GETJPI wants (rsz is size in bytes that
4010        * were needed to hold all identifiers at time of last call; we'll
4011        * allocate that many unsigned long ints), and go back and get 'em.
4012        * If it gave us less than it wanted to despite ample buffer space,
4013        * something's broken.  Is your system missing a system identifier?
4014        */
4015       if (rsz <= jpilist[1].buflen) {
4016          /* Perl_croak accvios when used this early in startup. */
4017          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4018                          rsz, (unsigned long) jpilist[1].buflen,
4019                          "Check your rights database for corruption.\n");
4020          exit(SS$_ABORT);
4021       }
4022       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4023       jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4024       jpilist[1].buflen = rsz * sizeof(unsigned long int);
4025       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4026       _ckvmssts_noperl(iosb[0]);
4027     }
4028     mask = jpilist[1].bufadr;
4029     /* Check attribute flags for each identifier (2nd longword); protected
4030      * subsystem identifiers trigger tainting.
4031      */
4032     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4033       if (mask[i] & KGB$M_SUBSYSTEM) {
4034         will_taint = TRUE;
4035         break;
4036       }
4037     }
4038     if (mask != rlst) Safefree(mask);
4039   }
4040   /* We need to use this hack to tell Perl it should run with tainting,
4041    * since its tainting flag may be part of the PL_curinterp struct, which
4042    * hasn't been allocated when vms_image_init() is called.
4043    */
4044   if (will_taint) {
4045     char ***newap;
4046     New(1320,newap,*argcp+2,char **);
4047     newap[0] = argvp[0];
4048     *newap[1] = "-T";
4049     Copy(argvp[1],newap[2],*argcp-1,char **);
4050     /* We orphan the old argv, since we don't know where it's come from,
4051      * so we don't know how to free it.
4052      */
4053     *argcp++; argvp = newap;
4054   }
4055   else {  /* Did user explicitly request tainting? */
4056     int i;
4057     char *cp, **av = *argvp;
4058     for (i = 1; i < *argcp; i++) {
4059       if (*av[i] != '-') break;
4060       for (cp = av[i]+1; *cp; cp++) {
4061         if (*cp == 'T') { will_taint = 1; break; }
4062         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4063                   strchr("DFIiMmx",*cp)) break;
4064       }
4065       if (will_taint) break;
4066     }
4067   }
4068
4069   for (tabidx = 0;
4070        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4071        tabidx++) {
4072     if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4073     else if (tabidx >= tabct) {
4074       tabct += 8;
4075       Renew(tabvec,tabct,struct dsc$descriptor_s *);
4076     }
4077     New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4078     tabvec[tabidx]->dsc$w_length  = 0;
4079     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
4080     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
4081     tabvec[tabidx]->dsc$a_pointer = NULL;
4082     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4083   }
4084   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4085
4086   getredirection(argcp,argvp);
4087 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4088   {
4089 # include <reentrancy.h>
4090   (void) decc$set_reentrancy(C$C_MULTITHREAD);
4091   }
4092 #endif
4093   return;
4094 }
4095 /*}}}*/
4096
4097
4098 /* trim_unixpath()
4099  * Trim Unix-style prefix off filespec, so it looks like what a shell
4100  * glob expansion would return (i.e. from specified prefix on, not
4101  * full path).  Note that returned filespec is Unix-style, regardless
4102  * of whether input filespec was VMS-style or Unix-style.
4103  *
4104  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4105  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
4106  * vector of options; at present, only bit 0 is used, and if set tells
4107  * trim unixpath to try the current default directory as a prefix when
4108  * presented with a possibly ambiguous ... wildcard.
4109  *
4110  * Returns !=0 on success, with trimmed filespec replacing contents of
4111  * fspec, and 0 on failure, with contents of fpsec unchanged.
4112  */
4113 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4114 int
4115 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4116 {
4117   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4118        *template, *base, *end, *cp1, *cp2;
4119   register int tmplen, reslen = 0, dirs = 0;
4120
4121   if (!wildspec || !fspec) return 0;
4122   if (strpbrk(wildspec,"]>:") != NULL) {
4123     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4124     else template = unixwild;
4125   }
4126   else template = wildspec;
4127   if (strpbrk(fspec,"]>:") != NULL) {
4128     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4129     else base = unixified;
4130     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4131      * check to see that final result fits into (isn't longer than) fspec */
4132     reslen = strlen(fspec);
4133   }
4134   else base = fspec;
4135
4136   /* No prefix or absolute path on wildcard, so nothing to remove */
4137   if (!*template || *template == '/') {
4138     if (base == fspec) return 1;
4139     tmplen = strlen(unixified);
4140     if (tmplen > reslen) return 0;  /* not enough space */
4141     /* Copy unixified resultant, including trailing NUL */
4142     memmove(fspec,unixified,tmplen+1);
4143     return 1;
4144   }
4145
4146   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
4147   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4148     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4149     for (cp1 = end ;cp1 >= base; cp1--)
4150       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4151         { cp1++; break; }
4152     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4153     return 1;
4154   }
4155   else {
4156     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4157     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4158     int ells = 1, totells, segdirs, match;
4159     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4160                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4161
4162     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4163     totells = ells;
4164     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4165     if (ellipsis == template && opts & 1) {
4166       /* Template begins with an ellipsis.  Since we can't tell how many
4167        * directory names at the front of the resultant to keep for an
4168        * arbitrary starting point, we arbitrarily choose the current
4169        * default directory as a starting point.  If it's there as a prefix,
4170        * clip it off.  If not, fall through and act as if the leading
4171        * ellipsis weren't there (i.e. return shortest possible path that
4172        * could match template).
4173        */
4174       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4175       for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4176         if (_tolower(*cp1) != _tolower(*cp2)) break;
4177       segdirs = dirs - totells;  /* Min # of dirs we must have left */
4178       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4179       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4180         memcpy(fspec,cp2+1,end - cp2);
4181         return 1;
4182       }
4183     }
4184     /* First off, back up over constant elements at end of path */
4185     if (dirs) {
4186       for (front = end ; front >= base; front--)
4187          if (*front == '/' && !dirs--) { front++; break; }
4188     }
4189     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4190          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
4191     if (cp1 != '\0') return 0;  /* Path too long. */
4192     lcend = cp2;
4193     *cp2 = '\0';  /* Pick up with memcpy later */
4194     lcfront = lcres + (front - base);
4195     /* Now skip over each ellipsis and try to match the path in front of it. */
4196     while (ells--) {
4197       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4198         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
4199             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
4200       if (cp1 < template) break; /* template started with an ellipsis */
4201       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4202         ellipsis = cp1; continue;
4203       }
4204       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4205       nextell = cp1;
4206       for (segdirs = 0, cp2 = tpl;
4207            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4208            cp1++, cp2++) {
4209          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4210          else *cp2 = _tolower(*cp1);  /* else lowercase for match */
4211          if (*cp2 == '/') segdirs++;
4212       }
4213       if (cp1 != ellipsis - 1) return 0; /* Path too long */
4214       /* Back up at least as many dirs as in template before matching */
4215       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4216         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4217       for (match = 0; cp1 > lcres;) {
4218         resdsc.dsc$a_pointer = cp1;
4219         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4220           match++;
4221           if (match == 1) lcfront = cp1;
4222         }
4223         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4224       }
4225       if (!match) return 0;  /* Can't find prefix ??? */
4226       if (match > 1 && opts & 1) {
4227         /* This ... wildcard could cover more than one set of dirs (i.e.
4228          * a set of similar dir names is repeated).  If the template
4229          * contains more than 1 ..., upstream elements could resolve the
4230          * ambiguity, but it's not worth a full backtracking setup here.
4231          * As a quick heuristic, clip off the current default directory
4232          * if it's present to find the trimmed spec, else use the
4233          * shortest string that this ... could cover.
4234          */
4235         char def[NAM$C_MAXRSS+1], *st;
4236
4237         if (getcwd(def, sizeof def,0) == NULL) return 0;
4238         for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4239           if (_tolower(*cp1) != _tolower(*cp2)) break;
4240         segdirs = dirs - totells;  /* Min # of dirs we must have left */
4241         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4242         if (*cp1 == '\0' && *cp2 == '/') {
4243           memcpy(fspec,cp2+1,end - cp2);
4244           return 1;
4245         }
4246         /* Nope -- stick with lcfront from above and keep going. */
4247       }
4248     }
4249     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4250     return 1;
4251     ellipsis = nextell;
4252   }
4253
4254 }  /* end of trim_unixpath() */
4255 /*}}}*/
4256
4257
4258 /*
4259  *  VMS readdir() routines.
4260  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4261  *
4262  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
4263  *  Minor modifications to original routines.
4264  */
4265
4266     /* Number of elements in vms_versions array */
4267 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
4268
4269 /*
4270  *  Open a directory, return a handle for later use.
4271  */
4272 /*{{{ DIR *opendir(char*name) */
4273 DIR *
4274 Perl_opendir(pTHX_ char *name)
4275 {
4276     DIR *dd;
4277     char dir[NAM$C_MAXRSS+1];
4278     Stat_t sb;
4279
4280     if (do_tovmspath(name,dir,0) == NULL) {
4281       return NULL;
4282     }
4283     if (flex_stat(dir,&sb) == -1) return NULL;
4284     if (!S_ISDIR(sb.st_mode)) {
4285       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
4286       return NULL;
4287     }
4288     if (!cando_by_name(S_IRUSR,0,dir)) {
4289       set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4290       return NULL;
4291     }
4292     /* Get memory for the handle, and the pattern. */
4293     New(1306,dd,1,DIR);
4294     New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4295
4296     /* Fill in the fields; mainly playing with the descriptor. */
4297     (void)sprintf(dd->pattern, "%s*.*",dir);
4298     dd->context = 0;
4299     dd->count = 0;
4300     dd->vms_wantversions = 0;
4301     dd->pat.dsc$a_pointer = dd->pattern;
4302     dd->pat.dsc$w_length = strlen(dd->pattern);
4303     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4304     dd->pat.dsc$b_class = DSC$K_CLASS_S;
4305
4306     return dd;
4307 }  /* end of opendir() */
4308 /*}}}*/
4309
4310 /*
4311  *  Set the flag to indicate we want versions or not.
4312  */
4313 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4314 void
4315 vmsreaddirversions(DIR *dd, int flag)
4316 {
4317     dd->vms_wantversions = flag;
4318 }
4319 /*}}}*/
4320
4321 /*
4322  *  Free up an opened directory.
4323  */
4324 /*{{{ void closedir(DIR *dd)*/
4325 void
4326 closedir(DIR *dd)
4327 {
4328     (void)lib$find_file_end(&dd->context);
4329     Safefree(dd->pattern);
4330     Safefree((char *)dd);
4331 }
4332 /*}}}*/
4333
4334 /*
4335  *  Collect all the version numbers for the current file.
4336  */
4337 static void
4338 collectversions(pTHX_ DIR *dd)
4339 {
4340     struct dsc$descriptor_s     pat;
4341     struct dsc$descriptor_s     res;
4342     struct dirent *e;
4343     char *p, *text, buff[sizeof dd->entry.d_name];
4344     int i;
4345     unsigned long context, tmpsts;
4346
4347     /* Convenient shorthand. */
4348     e = &dd->entry;
4349
4350     /* Add the version wildcard, ignoring the "*.*" put on before */
4351     i = strlen(dd->pattern);
4352     New(1308,text,i + e->d_namlen + 3,char);
4353     (void)strcpy(text, dd->pattern);
4354     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4355
4356     /* Set up the pattern descriptor. */
4357     pat.dsc$a_pointer = text;
4358     pat.dsc$w_length = i + e->d_namlen - 1;
4359     pat.dsc$b_dtype = DSC$K_DTYPE_T;
4360     pat.dsc$b_class = DSC$K_CLASS_S;
4361
4362     /* Set up result descriptor. */
4363     res.dsc$a_pointer = buff;
4364     res.dsc$w_length = sizeof buff - 2;
4365     res.dsc$b_dtype = DSC$K_DTYPE_T;
4366     res.dsc$b_class = DSC$K_CLASS_S;
4367
4368     /* Read files, collecting versions. */
4369     for (context = 0, e->vms_verscount = 0;
4370          e->vms_verscount < VERSIZE(e);
4371          e->vms_verscount++) {
4372         tmpsts = lib$find_file(&pat, &res, &context);
4373         if (tmpsts == RMS$_NMF || context == 0) break;
4374         _ckvmssts(tmpsts);
4375         buff[sizeof buff - 1] = '\0';
4376         if ((p = strchr(buff, ';')))
4377             e->vms_versions[e->vms_verscount] = atoi(p + 1);
4378         else
4379             e->vms_versions[e->vms_verscount] = -1;
4380     }
4381
4382     _ckvmssts(lib$find_file_end(&context));
4383     Safefree(text);
4384
4385 }  /* end of collectversions() */
4386
4387 /*
4388  *  Read the next entry from the directory.
4389  */
4390 /*{{{ struct dirent *readdir(DIR *dd)*/
4391 struct dirent *
4392 Perl_readdir(pTHX_ DIR *dd)
4393 {
4394     struct dsc$descriptor_s     res;
4395     char *p, buff[sizeof dd->entry.d_name];
4396     unsigned long int tmpsts;
4397
4398     /* Set up result descriptor, and get next file. */
4399     res.dsc$a_pointer = buff;
4400     res.dsc$w_length = sizeof buff - 2;
4401     res.dsc$b_dtype = DSC$K_DTYPE_T;
4402     res.dsc$b_class = DSC$K_CLASS_S;
4403     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4404     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
4405     if (!(tmpsts & 1)) {
4406       set_vaxc_errno(tmpsts);
4407       switch (tmpsts) {
4408         case RMS$_PRV:
4409           set_errno(EACCES); break;
4410         case RMS$_DEV:
4411           set_errno(ENODEV); break;
4412         case RMS$_DIR:
4413           set_errno(ENOTDIR); break;
4414         case RMS$_FNF: case RMS$_DNF:
4415           set_errno(ENOENT); break;
4416         default:
4417           set_errno(EVMSERR);
4418       }
4419       return NULL;
4420     }
4421     dd->count++;
4422     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4423     buff[sizeof buff - 1] = '\0';
4424     for (p = buff; *p; p++) *p = _tolower(*p);
4425     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
4426     *p = '\0';
4427
4428     /* Skip any directory component and just copy the name. */
4429     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4430     else (void)strcpy(dd->entry.d_name, buff);
4431
4432     /* Clobber the version. */
4433     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4434
4435     dd->entry.d_namlen = strlen(dd->entry.d_name);
4436     dd->entry.vms_verscount = 0;
4437     if (dd->vms_wantversions) collectversions(aTHX_ dd);
4438     return &dd->entry;
4439
4440 }  /* end of readdir() */
4441 /*}}}*/
4442
4443 /*
4444  *  Return something that can be used in a seekdir later.
4445  */
4446 /*{{{ long telldir(DIR *dd)*/
4447 long
4448 telldir(DIR *dd)
4449 {
4450     return dd->count;
4451 }
4452 /*}}}*/
4453
4454 /*
4455  *  Return to a spot where we used to be.  Brute force.
4456  */
4457 /*{{{ void seekdir(DIR *dd,long count)*/
4458 void
4459 Perl_seekdir(pTHX_ DIR *dd, long count)
4460 {
4461     int vms_wantversions;
4462
4463     /* If we haven't done anything yet... */
4464     if (dd->count == 0)
4465         return;
4466
4467     /* Remember some state, and clear it. */
4468     vms_wantversions = dd->vms_wantversions;
4469     dd->vms_wantversions = 0;
4470     _ckvmssts(lib$find_file_end(&dd->context));
4471     dd->context = 0;
4472
4473     /* The increment is in readdir(). */
4474     for (dd->count = 0; dd->count < count; )
4475         (void)readdir(dd);
4476
4477     dd->vms_wantversions = vms_wantversions;
4478
4479 }  /* end of seekdir() */
4480 /*}}}*/
4481
4482 /* VMS subprocess management
4483  *
4484  * my_vfork() - just a vfork(), after setting a flag to record that
4485  * the current script is trying a Unix-style fork/exec.
4486  *
4487  * vms_do_aexec() and vms_do_exec() are called in response to the
4488  * perl 'exec' function.  If this follows a vfork call, then they
4489  * call out the the regular perl routines in doio.c which do an
4490  * execvp (for those who really want to try this under VMS).
4491  * Otherwise, they do exactly what the perl docs say exec should
4492  * do - terminate the current script and invoke a new command
4493  * (See below for notes on command syntax.)
4494  *
4495  * do_aspawn() and do_spawn() implement the VMS side of the perl
4496  * 'system' function.
4497  *
4498  * Note on command arguments to perl 'exec' and 'system': When handled
4499  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4500  * are concatenated to form a DCL command string.  If the first arg
4501  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4502  * the the command string is handed off to DCL directly.  Otherwise,
4503  * the first token of the command is taken as the filespec of an image
4504  * to run.  The filespec is expanded using a default type of '.EXE' and
4505  * the process defaults for device, directory, etc., and if found, the resultant
4506  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4507  * the command string as parameters.  This is perhaps a bit complicated,
4508  * but I hope it will form a happy medium between what VMS folks expect
4509  * from lib$spawn and what Unix folks expect from exec.
4510  */
4511
4512 static int vfork_called;
4513
4514 /*{{{int my_vfork()*/
4515 int
4516 my_vfork()
4517 {
4518   vfork_called++;
4519   return vfork();
4520 }
4521 /*}}}*/
4522
4523
4524 static void
4525 vms_execfree(pTHX) {
4526   if (PL_Cmd) {
4527     if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4528     PL_Cmd = Nullch;
4529   }
4530   if (VMScmd.dsc$a_pointer) {
4531     Safefree(VMScmd.dsc$a_pointer);
4532     VMScmd.dsc$w_length = 0;
4533     VMScmd.dsc$a_pointer = Nullch;
4534   }
4535 }
4536
4537 static char *
4538 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4539 {
4540   char *junk, *tmps = Nullch;
4541   register size_t cmdlen = 0;
4542   size_t rlen;
4543   register SV **idx;
4544   STRLEN n_a;
4545
4546   idx = mark;
4547   if (really) {
4548     tmps = SvPV(really,rlen);
4549     if (*tmps) {
4550       cmdlen += rlen + 1;
4551       idx++;
4552     }
4553   }
4554
4555   for (idx++; idx <= sp; idx++) {
4556     if (*idx) {
4557       junk = SvPVx(*idx,rlen);
4558       cmdlen += rlen ? rlen + 1 : 0;
4559     }
4560   }
4561   New(401,PL_Cmd,cmdlen+1,char);
4562
4563   if (tmps && *tmps) {
4564     strcpy(PL_Cmd,tmps);
4565     mark++;
4566   }
4567   else *PL_Cmd = '\0';
4568   while (++mark <= sp) {
4569     if (*mark) {
4570       char *s = SvPVx(*mark,n_a);
4571       if (!*s) continue;
4572       if (*PL_Cmd) strcat(PL_Cmd," ");
4573       strcat(PL_Cmd,s);
4574     }
4575   }
4576   return PL_Cmd;
4577
4578 }  /* end of setup_argstr() */
4579
4580 #define MAX_DCL_LINE_LENGTH   255
4581
4582 static unsigned long int
4583 setup_cmddsc(pTHX_ char *cmd, int check_img)
4584 {
4585   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4586   $DESCRIPTOR(defdsc,".EXE");
4587   $DESCRIPTOR(defdsc2,".");
4588   $DESCRIPTOR(resdsc,resspec);
4589   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4590   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4591   register char *s, *rest, *cp, *wordbreak;
4592   register int isdcl;
4593
4594   if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
4595     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
4596   s = cmd;
4597   while (*s && isspace(*s)) s++;
4598
4599   if (*s == '@' || *s == '$') {
4600     vmsspec[0] = *s;  rest = s + 1;
4601     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4602   }
4603   else { cp = vmsspec; rest = s; }
4604   if (*rest == '.' || *rest == '/') {
4605     char *cp2;
4606     for (cp2 = resspec;
4607          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4608          rest++, cp2++) *cp2 = *rest;
4609     *cp2 = '\0';
4610     if (do_tovmsspec(resspec,cp,0)) {
4611       s = vmsspec;
4612       if (*rest) {
4613         for (cp2 = vmsspec + strlen(vmsspec);
4614              *rest && cp2 - vmsspec < sizeof vmsspec;
4615              rest++, cp2++) *cp2 = *rest;
4616         *cp2 = '\0';
4617       }
4618     }
4619   }
4620   /* Intuit whether verb (first word of cmd) is a DCL command:
4621    *   - if first nonspace char is '@', it's a DCL indirection
4622    * otherwise
4623    *   - if verb contains a filespec separator, it's not a DCL command
4624    *   - if it doesn't, caller tells us whether to default to a DCL
4625    *     command, or to a local image unless told it's DCL (by leading '$')
4626    */
4627   if (*s == '@') isdcl = 1;
4628   else {
4629     register char *filespec = strpbrk(s,":<[.;");
4630     rest = wordbreak = strpbrk(s," \"\t/");
4631     if (!wordbreak) wordbreak = s + strlen(s);
4632     if (*s == '$') check_img = 0;
4633     if (filespec && (filespec < wordbreak)) isdcl = 0;
4634     else isdcl = !check_img;
4635   }
4636
4637   if (!isdcl) {
4638     imgdsc.dsc$a_pointer = s;
4639     imgdsc.dsc$w_length = wordbreak - s;
4640     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4641     if (!(retsts&1)) {
4642         _ckvmssts(lib$find_file_end(&cxt));
4643         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4644     if (!(retsts & 1) && *s == '$') {
4645           _ckvmssts(lib$find_file_end(&cxt));
4646       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4647       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4648           if (!(retsts&1)) {
4649       _ckvmssts(lib$find_file_end(&cxt));
4650             retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4651           }
4652     }
4653     }
4654     _ckvmssts(lib$find_file_end(&cxt));
4655
4656     if (retsts & 1) {
4657       FILE *fp;
4658       s = resspec;
4659       while (*s && !isspace(*s)) s++;
4660       *s = '\0';
4661
4662       /* check that it's really not DCL with no file extension */
4663       fp = fopen(resspec,"r","ctx=bin,shr=get");
4664       if (fp) {
4665         char b[4] = {0,0,0,0};
4666         read(fileno(fp),b,4);
4667         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4668         fclose(fp);
4669       }
4670       if (check_img && isdcl) return RMS$_FNF;
4671
4672       if (cando_by_name(S_IXUSR,0,resspec)) {
4673         New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4674         if (!isdcl) {
4675             strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4676         } else {
4677             strcpy(VMScmd.dsc$a_pointer,"@");
4678         }
4679         strcat(VMScmd.dsc$a_pointer,resspec);
4680         if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4681         VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4682         return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
4683       }
4684       else retsts = RMS$_PRV;
4685     }
4686   }
4687   /* It's either a DCL command or we couldn't find a suitable image */
4688   VMScmd.dsc$w_length = strlen(cmd);
4689   if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4690   else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4691   if (!(retsts & 1)) {
4692     /* just hand off status values likely to be due to user error */
4693     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4694         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4695        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4696     else { _ckvmssts(retsts); }
4697   }
4698
4699   return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
4700
4701 }  /* end of setup_cmddsc() */
4702
4703
4704 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4705 bool
4706 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
4707 {
4708   if (sp > mark) {
4709     if (vfork_called) {           /* this follows a vfork - act Unixish */
4710       vfork_called--;
4711       if (vfork_called < 0) {
4712         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4713         vfork_called = 0;
4714       }
4715       else return do_aexec(really,mark,sp);
4716     }
4717                                            /* no vfork - act VMSish */
4718     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
4719
4720   }
4721
4722   return FALSE;
4723 }  /* end of vms_do_aexec() */
4724 /*}}}*/
4725
4726 /* {{{bool vms_do_exec(char *cmd) */
4727 bool
4728 Perl_vms_do_exec(pTHX_ char *cmd)
4729 {
4730
4731   if (vfork_called) {             /* this follows a vfork - act Unixish */
4732     vfork_called--;
4733     if (vfork_called < 0) {
4734       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4735       vfork_called = 0;
4736     }
4737     else return do_exec(cmd);
4738   }
4739
4740   {                               /* no vfork - act VMSish */
4741     unsigned long int retsts;
4742
4743     TAINT_ENV();
4744     TAINT_PROPER("exec");
4745     if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1)
4746       retsts = lib$do_command(&VMScmd);
4747
4748     switch (retsts) {
4749       case RMS$_FNF: case RMS$_DNF:
4750         set_errno(ENOENT); break;
4751       case RMS$_DIR:
4752         set_errno(ENOTDIR); break;
4753       case RMS$_DEV:
4754         set_errno(ENODEV); break;
4755       case RMS$_PRV:
4756         set_errno(EACCES); break;
4757       case RMS$_SYN:
4758         set_errno(EINVAL); break;
4759       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4760         set_errno(E2BIG); break;
4761       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4762         _ckvmssts(retsts); /* fall through */
4763       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4764         set_errno(EVMSERR);
4765     }
4766     set_vaxc_errno(retsts);
4767     if (ckWARN(WARN_EXEC)) {
4768       Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4769              VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
4770     }
4771     vms_execfree(aTHX);
4772   }
4773
4774   return FALSE;
4775
4776 }  /* end of vms_do_exec() */
4777 /*}}}*/
4778
4779 unsigned long int Perl_do_spawn(pTHX_ char *);
4780
4781 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
4782 unsigned long int
4783 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
4784 {
4785   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
4786
4787   return SS$_ABORT;
4788 }  /* end of do_aspawn() */
4789 /*}}}*/
4790
4791 /* {{{unsigned long int do_spawn(char *cmd) */
4792 unsigned long int
4793 Perl_do_spawn(pTHX_ char *cmd)
4794 {
4795   unsigned long int sts, substs, hadcmd = 1;
4796
4797   TAINT_ENV();
4798   TAINT_PROPER("spawn");
4799   if (!cmd || !*cmd) {
4800     hadcmd = 0;
4801     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
4802   }
4803   else {
4804     sts = setup_cmddsc(aTHX_ cmd,0);
4805     if (sts & 1) {
4806         sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
4807     } else {
4808         substs = sts; /* didn't spawn, use command setup failure for return */
4809     }
4810   }
4811
4812   if (!(sts & 1)) {
4813     switch (sts) {
4814       case RMS$_FNF:  case RMS$_DNF:
4815         set_errno(ENOENT); break;
4816       case RMS$_DIR:
4817         set_errno(ENOTDIR); break;
4818       case RMS$_DEV:
4819         set_errno(ENODEV); break;
4820       case RMS$_PRV:
4821         set_errno(EACCES); break;
4822       case RMS$_SYN:
4823         set_errno(EINVAL); break;
4824       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4825         set_errno(E2BIG); break;
4826       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4827         _ckvmssts(sts); /* fall through */
4828       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4829         set_errno(EVMSERR);
4830     }
4831     set_vaxc_errno(sts);
4832     if (ckWARN(WARN_EXEC)) {
4833       Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
4834              hadcmd ? VMScmd.dsc$w_length :  0,
4835              hadcmd ? VMScmd.dsc$a_pointer : "",
4836              Strerror(errno));
4837     }
4838   }
4839   vms_execfree(aTHX);
4840   return substs;
4841
4842 }  /* end of do_spawn() */
4843 /*}}}*/
4844
4845
4846 static unsigned int *sockflags, sockflagsize;
4847
4848 /*
4849  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
4850  * routines found in some versions of the CRTL can't deal with sockets.
4851  * We don't shim the other file open routines since a socket isn't
4852  * likely to be opened by a name.
4853  */
4854 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
4855 FILE *my_fdopen(int fd, const char *mode)
4856 {
4857   FILE *fp = fdopen(fd, (char *) mode);
4858
4859   if (fp) {
4860     unsigned int fdoff = fd / sizeof(unsigned int);
4861     struct stat sbuf; /* native stat; we don't need flex_stat */
4862     if (!sockflagsize || fdoff > sockflagsize) {
4863       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
4864       else           New  (1324,sockflags,fdoff+2,unsigned int);
4865       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
4866       sockflagsize = fdoff + 2;
4867     }
4868     if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
4869       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
4870   }
4871   return fp;
4872
4873 }
4874 /*}}}*/
4875
4876
4877 /*
4878  * Clear the corresponding bit when the (possibly) socket stream is closed.
4879  * There still a small hole: we miss an implicit close which might occur
4880  * via freopen().  >> Todo
4881  */
4882 /*{{{ int my_fclose(FILE *fp)*/
4883 int my_fclose(FILE *fp) {
4884   if (fp) {
4885     unsigned int fd = fileno(fp);
4886     unsigned int fdoff = fd / sizeof(unsigned int);
4887
4888     if (sockflagsize && fdoff <= sockflagsize)
4889       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
4890   }
4891   return fclose(fp);
4892 }
4893 /*}}}*/
4894
4895
4896 /*
4897  * A simple fwrite replacement which outputs itmsz*nitm chars without
4898  * introducing record boundaries every itmsz chars.
4899  * We are using fputs, which depends on a terminating null.  We may
4900  * well be writing binary data, so we need to accommodate not only
4901  * data with nulls sprinkled in the middle but also data with no null
4902  * byte at the end.
4903  */
4904 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
4905 int
4906 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
4907 {
4908   register char *cp, *end, *cpd, *data;
4909   register unsigned int fd = fileno(dest);
4910   register unsigned int fdoff = fd / sizeof(unsigned int);
4911   int retval;
4912   int bufsize = itmsz * nitm + 1;
4913
4914   if (fdoff < sockflagsize &&
4915       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
4916     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
4917     return nitm;
4918   }
4919
4920   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
4921   memcpy( data, src, itmsz*nitm );
4922   data[itmsz*nitm] = '\0';
4923
4924   end = data + itmsz * nitm;
4925   retval = (int) nitm; /* on success return # items written */
4926
4927   cpd = data;
4928   while (cpd <= end) {
4929     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
4930     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
4931     if (cp < end)
4932       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
4933     cpd = cp + 1;
4934   }
4935
4936   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
4937   return retval;
4938
4939 }  /* end of my_fwrite() */
4940 /*}}}*/
4941
4942 /*{{{ int my_flush(FILE *fp)*/
4943 int
4944 Perl_my_flush(pTHX_ FILE *fp)
4945 {
4946     int res;
4947     if ((res = fflush(fp)) == 0 && fp) {
4948 #ifdef VMS_DO_SOCKETS
4949         Stat_t s;
4950         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
4951 #endif
4952             res = fsync(fileno(fp));
4953     }
4954 /*
4955  * If the flush succeeded but set end-of-file, we need to clear
4956  * the error because our caller may check ferror().  BTW, this
4957  * probably means we just flushed an empty file.
4958  */
4959     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
4960
4961     return res;
4962 }
4963 /*}}}*/
4964
4965 /*
4966  * Here are replacements for the following Unix routines in the VMS environment:
4967  *      getpwuid    Get information for a particular UIC or UID
4968  *      getpwnam    Get information for a named user
4969  *      getpwent    Get information for each user in the rights database
4970  *      setpwent    Reset search to the start of the rights database
4971  *      endpwent    Finish searching for users in the rights database
4972  *
4973  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
4974  * (defined in pwd.h), which contains the following fields:-
4975  *      struct passwd {
4976  *              char        *pw_name;    Username (in lower case)
4977  *              char        *pw_passwd;  Hashed password
4978  *              unsigned int pw_uid;     UIC
4979  *              unsigned int pw_gid;     UIC group  number
4980  *              char        *pw_unixdir; Default device/directory (VMS-style)
4981  *              char        *pw_gecos;   Owner name
4982  *              char        *pw_dir;     Default device/directory (Unix-style)
4983  *              char        *pw_shell;   Default CLI name (eg. DCL)
4984  *      };
4985  * If the specified user does not exist, getpwuid and getpwnam return NULL.
4986  *
4987  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
4988  * not the UIC member number (eg. what's returned by getuid()),
4989  * getpwuid() can accept either as input (if uid is specified, the caller's
4990  * UIC group is used), though it won't recognise gid=0.
4991  *
4992  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
4993  * information about other users in your group or in other groups, respectively.
4994  * If the required privilege is not available, then these routines fill only
4995  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
4996  * string).
4997  *
4998  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
4999  */
5000
5001 /* sizes of various UAF record fields */
5002 #define UAI$S_USERNAME 12
5003 #define UAI$S_IDENT    31
5004 #define UAI$S_OWNER    31
5005 #define UAI$S_DEFDEV   31
5006 #define UAI$S_DEFDIR   63
5007 #define UAI$S_DEFCLI   31
5008 #define UAI$S_PWD       8
5009
5010 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
5011                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5012                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
5013
5014 static char __empty[]= "";
5015 static struct passwd __passwd_empty=
5016     {(char *) __empty, (char *) __empty, 0, 0,
5017      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5018 static int contxt= 0;
5019 static struct passwd __pwdcache;
5020 static char __pw_namecache[UAI$S_IDENT+1];
5021
5022 /*
5023  * This routine does most of the work extracting the user information.
5024  */
5025 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5026 {
5027     static struct {
5028         unsigned char length;
5029         char pw_gecos[UAI$S_OWNER+1];
5030     } owner;
5031     static union uicdef uic;
5032     static struct {
5033         unsigned char length;
5034         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5035     } defdev;
5036     static struct {
5037         unsigned char length;
5038         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5039     } defdir;
5040     static struct {
5041         unsigned char length;
5042         char pw_shell[UAI$S_DEFCLI+1];
5043     } defcli;
5044     static char pw_passwd[UAI$S_PWD+1];
5045
5046     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5047     struct dsc$descriptor_s name_desc;
5048     unsigned long int sts;
5049
5050     static struct itmlst_3 itmlst[]= {
5051         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
5052         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
5053         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
5054         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
5055         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
5056         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
5057         {0,                0,           NULL,    NULL}};
5058
5059     name_desc.dsc$w_length=  strlen(name);
5060     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5061     name_desc.dsc$b_class=   DSC$K_CLASS_S;
5062     name_desc.dsc$a_pointer= (char *) name;
5063
5064 /*  Note that sys$getuai returns many fields as counted strings. */
5065     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5066     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5067       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5068     }
5069     else { _ckvmssts(sts); }
5070     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
5071
5072     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
5073     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5074     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5075     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5076     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5077     owner.pw_gecos[lowner]=            '\0';
5078     defdev.pw_dir[ldefdev+ldefdir]= '\0';
5079     defcli.pw_shell[ldefcli]=          '\0';
5080     if (valid_uic(uic)) {
5081         pwd->pw_uid= uic.uic$l_uic;
5082         pwd->pw_gid= uic.uic$v_group;
5083     }
5084     else
5085       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5086     pwd->pw_passwd=  pw_passwd;
5087     pwd->pw_gecos=   owner.pw_gecos;
5088     pwd->pw_dir=     defdev.pw_dir;
5089     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5090     pwd->pw_shell=   defcli.pw_shell;
5091     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5092         int ldir;
5093         ldir= strlen(pwd->pw_unixdir) - 1;
5094         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5095     }
5096     else
5097         strcpy(pwd->pw_unixdir, pwd->pw_dir);
5098     __mystrtolower(pwd->pw_unixdir);
5099     return 1;
5100 }
5101
5102 /*
5103  * Get information for a named user.
5104 */
5105 /*{{{struct passwd *getpwnam(char *name)*/
5106 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5107 {
5108     struct dsc$descriptor_s name_desc;
5109     union uicdef uic;
5110     unsigned long int status, sts;
5111
5112     __pwdcache = __passwd_empty;
5113     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5114       /* We still may be able to determine pw_uid and pw_gid */
5115       name_desc.dsc$w_length=  strlen(name);
5116       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5117       name_desc.dsc$b_class=   DSC$K_CLASS_S;
5118       name_desc.dsc$a_pointer= (char *) name;
5119       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5120         __pwdcache.pw_uid= uic.uic$l_uic;
5121         __pwdcache.pw_gid= uic.uic$v_group;
5122       }
5123       else {
5124         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5125           set_vaxc_errno(sts);
5126           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5127           return NULL;
5128         }
5129         else { _ckvmssts(sts); }
5130       }
5131     }
5132     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5133     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5134     __pwdcache.pw_name= __pw_namecache;
5135     return &__pwdcache;
5136 }  /* end of my_getpwnam() */
5137 /*}}}*/
5138
5139 /*
5140  * Get information for a particular UIC or UID.
5141  * Called by my_getpwent with uid=-1 to list all users.
5142 */
5143 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5144 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5145 {
5146     const $DESCRIPTOR(name_desc,__pw_namecache);
5147     unsigned short lname;
5148     union uicdef uic;
5149     unsigned long int status;
5150
5151     if (uid == (unsigned int) -1) {
5152       do {
5153         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5154         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5155           set_vaxc_errno(status);
5156           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5157           my_endpwent();
5158           return NULL;
5159         }
5160         else { _ckvmssts(status); }
5161       } while (!valid_uic (uic));
5162     }
5163     else {
5164       uic.uic$l_uic= uid;
5165       if (!uic.uic$v_group)
5166         uic.uic$v_group= PerlProc_getgid();
5167       if (valid_uic(uic))
5168         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5169       else status = SS$_IVIDENT;
5170       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5171           status == RMS$_PRV) {
5172         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5173         return NULL;
5174       }
5175       else { _ckvmssts(status); }
5176     }
5177     __pw_namecache[lname]= '\0';
5178     __mystrtolower(__pw_namecache);
5179
5180     __pwdcache = __passwd_empty;
5181     __pwdcache.pw_name = __pw_namecache;
5182
5183 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5184     The identifier's value is usually the UIC, but it doesn't have to be,
5185     so if we can, we let fillpasswd update this. */
5186     __pwdcache.pw_uid =  uic.uic$l_uic;
5187     __pwdcache.pw_gid =  uic.uic$v_group;
5188
5189     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5190     return &__pwdcache;
5191
5192 }  /* end of my_getpwuid() */
5193 /*}}}*/
5194
5195 /*
5196  * Get information for next user.
5197 */
5198 /*{{{struct passwd *my_getpwent()*/
5199 struct passwd *Perl_my_getpwent(pTHX)
5200 {
5201     return (my_getpwuid((unsigned int) -1));
5202 }
5203 /*}}}*/
5204
5205 /*
5206  * Finish searching rights database for users.
5207 */
5208 /*{{{void my_endpwent()*/
5209 void Perl_my_endpwent(pTHX)
5210 {
5211     if (contxt) {
5212       _ckvmssts(sys$finish_rdb(&contxt));
5213       contxt= 0;
5214     }
5215 }
5216 /*}}}*/
5217
5218 #ifdef HOMEGROWN_POSIX_SIGNALS
5219   /* Signal handling routines, pulled into the core from POSIX.xs.
5220    *
5221    * We need these for threads, so they've been rolled into the core,
5222    * rather than left in POSIX.xs.
5223    *
5224    * (DRS, Oct 23, 1997)
5225    */
5226
5227   /* sigset_t is atomic under VMS, so these routines are easy */
5228 /*{{{int my_sigemptyset(sigset_t *) */
5229 int my_sigemptyset(sigset_t *set) {
5230     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5231     *set = 0; return 0;
5232 }
5233 /*}}}*/
5234
5235
5236 /*{{{int my_sigfillset(sigset_t *)*/
5237 int my_sigfillset(sigset_t *set) {
5238     int i;
5239     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5240     for (i = 0; i < NSIG; i++) *set |= (1 << i);
5241     return 0;
5242 }
5243 /*}}}*/
5244
5245
5246 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5247 int my_sigaddset(sigset_t *set, int sig) {
5248     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5249     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5250     *set |= (1 << (sig - 1));
5251     return 0;
5252 }
5253 /*}}}*/
5254
5255
5256 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5257 int my_sigdelset(sigset_t *set, int sig) {
5258     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5259     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5260     *set &= ~(1 << (sig - 1));
5261     return 0;
5262 }
5263 /*}}}*/
5264
5265
5266 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5267 int my_sigismember(sigset_t *set, int sig) {
5268     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5269     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5270     *set & (1 << (sig - 1));
5271 }
5272 /*}}}*/
5273
5274
5275 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5276 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5277     sigset_t tempmask;
5278
5279     /* If set and oset are both null, then things are badly wrong. Bail out. */
5280     if ((oset == NULL) && (set == NULL)) {
5281       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5282       return -1;
5283     }
5284
5285     /* If set's null, then we're just handling a fetch. */
5286     if (set == NULL) {
5287         tempmask = sigblock(0);
5288     }
5289     else {
5290       switch (how) {
5291       case SIG_SETMASK:
5292         tempmask = sigsetmask(*set);
5293         break;
5294       case SIG_BLOCK:
5295         tempmask = sigblock(*set);
5296         break;
5297       case SIG_UNBLOCK:
5298         tempmask = sigblock(0);
5299         sigsetmask(*oset & ~tempmask);
5300         break;
5301       default:
5302         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5303         return -1;
5304       }
5305     }
5306
5307     /* Did they pass us an oset? If so, stick our holding mask into it */
5308     if (oset)
5309       *oset = tempmask;
5310
5311     return 0;
5312 }
5313 /*}}}*/
5314 #endif  /* HOMEGROWN_POSIX_SIGNALS */
5315
5316
5317 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5318  * my_utime(), and flex_stat(), all of which operate on UTC unless
5319  * VMSISH_TIMES is true.
5320  */
5321 /* method used to handle UTC conversions:
5322  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
5323  */
5324 static int gmtime_emulation_type;
5325 /* number of secs to add to UTC POSIX-style time to get local time */
5326 static long int utc_offset_secs;
5327
5328 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5329  * in vmsish.h.  #undef them here so we can call the CRTL routines
5330  * directly.
5331  */
5332 #undef gmtime
5333 #undef localtime
5334 #undef time
5335
5336
5337 /*
5338  * DEC C previous to 6.0 corrupts the behavior of the /prefix
5339  * qualifier with the extern prefix pragma.  This provisional
5340  * hack circumvents this prefix pragma problem in previous
5341  * precompilers.
5342  */
5343 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5344 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5345 #    pragma __extern_prefix save
5346 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
5347 #    define gmtime decc$__utctz_gmtime
5348 #    define localtime decc$__utctz_localtime
5349 #    define time decc$__utc_time
5350 #    pragma __extern_prefix restore
5351
5352      struct tm *gmtime(), *localtime();
5353
5354 #  endif
5355 #endif
5356
5357
5358 static time_t toutc_dst(time_t loc) {
5359   struct tm *rsltmp;
5360
5361   if ((rsltmp = localtime(&loc)) == NULL) return -1;
5362   loc -= utc_offset_secs;
5363   if (rsltmp->tm_isdst) loc -= 3600;
5364   return loc;
5365 }
5366 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
5367        ((gmtime_emulation_type || my_time(NULL)), \
5368        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5369        ((secs) - utc_offset_secs))))
5370
5371 static time_t toloc_dst(time_t utc) {
5372   struct tm *rsltmp;
5373
5374   utc += utc_offset_secs;
5375   if ((rsltmp = localtime(&utc)) == NULL) return -1;
5376   if (rsltmp->tm_isdst) utc += 3600;
5377   return utc;
5378 }
5379 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
5380        ((gmtime_emulation_type || my_time(NULL)), \
5381        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5382        ((secs) + utc_offset_secs))))
5383
5384 #ifndef RTL_USES_UTC
5385 /*
5386
5387     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
5388         DST starts on 1st sun of april      at 02:00  std time
5389             ends on last sun of october     at 02:00  dst time
5390     see the UCX management command reference, SET CONFIG TIMEZONE
5391     for formatting info.
5392
5393     No, it's not as general as it should be, but then again, NOTHING
5394     will handle UK times in a sensible way.
5395 */
5396
5397
5398 /*
5399     parse the DST start/end info:
5400     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5401 */
5402
5403 static char *
5404 tz_parse_startend(char *s, struct tm *w, int *past)
5405 {
5406     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5407     int ly, dozjd, d, m, n, hour, min, sec, j, k;
5408     time_t g;
5409
5410     if (!s)    return 0;
5411     if (!w) return 0;
5412     if (!past) return 0;
5413
5414     ly = 0;
5415     if (w->tm_year % 4        == 0) ly = 1;
5416     if (w->tm_year % 100      == 0) ly = 0;
5417     if (w->tm_year+1900 % 400 == 0) ly = 1;
5418     if (ly) dinm[1]++;
5419
5420     dozjd = isdigit(*s);
5421     if (*s == 'J' || *s == 'j' || dozjd) {
5422         if (!dozjd && !isdigit(*++s)) return 0;
5423         d = *s++ - '0';
5424         if (isdigit(*s)) {
5425             d = d*10 + *s++ - '0';
5426             if (isdigit(*s)) {
5427                 d = d*10 + *s++ - '0';
5428             }
5429         }
5430         if (d == 0) return 0;
5431         if (d > 366) return 0;
5432         d--;
5433         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
5434         g = d * 86400;
5435         dozjd = 1;
5436     } else if (*s == 'M' || *s == 'm') {
5437         if (!isdigit(*++s)) return 0;
5438         m = *s++ - '0';
5439         if (isdigit(*s)) m = 10*m + *s++ - '0';
5440         if (*s != '.') return 0;
5441         if (!isdigit(*++s)) return 0;
5442         n = *s++ - '0';
5443         if (n < 1 || n > 5) return 0;
5444         if (*s != '.') return 0;
5445         if (!isdigit(*++s)) return 0;
5446         d = *s++ - '0';
5447         if (d > 6) return 0;
5448     }
5449
5450     if (*s == '/') {
5451         if (!isdigit(*++s)) return 0;
5452         hour = *s++ - '0';
5453         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5454         if (*s == ':') {
5455             if (!isdigit(*++s)) return 0;
5456             min = *s++ - '0';
5457             if (isdigit(*s)) min = 10*min + *s++ - '0';
5458             if (*s == ':') {
5459                 if (!isdigit(*++s)) return 0;
5460                 sec = *s++ - '0';
5461                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5462             }
5463         }
5464     } else {
5465         hour = 2;
5466         min = 0;
5467         sec = 0;
5468     }
5469
5470     if (dozjd) {
5471         if (w->tm_yday < d) goto before;
5472         if (w->tm_yday > d) goto after;
5473     } else {
5474         if (w->tm_mon+1 < m) goto before;
5475         if (w->tm_mon+1 > m) goto after;
5476
5477         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
5478         k = d - j; /* mday of first d */
5479         if (k <= 0) k += 7;
5480         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
5481         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5482         if (w->tm_mday < k) goto before;
5483         if (w->tm_mday > k) goto after;
5484     }
5485
5486     if (w->tm_hour < hour) goto before;
5487     if (w->tm_hour > hour) goto after;
5488     if (w->tm_min  < min)  goto before;
5489     if (w->tm_min  > min)  goto after;
5490     if (w->tm_sec  < sec)  goto before;
5491     goto after;
5492
5493 before:
5494     *past = 0;
5495     return s;
5496 after:
5497     *past = 1;
5498     return s;
5499 }
5500
5501
5502
5503
5504 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
5505
5506 static char *
5507 tz_parse_offset(char *s, int *offset)
5508 {
5509     int hour = 0, min = 0, sec = 0;
5510     int neg = 0;
5511     if (!s) return 0;
5512     if (!offset) return 0;
5513
5514     if (*s == '-') {neg++; s++;}
5515     if (*s == '+') s++;
5516     if (!isdigit(*s)) return 0;
5517     hour = *s++ - '0';
5518     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5519     if (hour > 24) return 0;
5520     if (*s == ':') {
5521         if (!isdigit(*++s)) return 0;
5522         min = *s++ - '0';
5523         if (isdigit(*s)) min = min*10 + (*s++ - '0');
5524         if (min > 59) return 0;
5525         if (*s == ':') {
5526             if (!isdigit(*++s)) return 0;
5527             sec = *s++ - '0';
5528             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5529             if (sec > 59) return 0;
5530         }
5531     }
5532
5533     *offset = (hour*60+min)*60 + sec;
5534     if (neg) *offset = -*offset;
5535     return s;
5536 }
5537
5538 /*
5539     input time is w, whatever type of time the CRTL localtime() uses.
5540     sets dst, the zone, and the gmtoff (seconds)
5541
5542     caches the value of TZ and UCX$TZ env variables; note that
5543     my_setenv looks for these and sets a flag if they're changed
5544     for efficiency.
5545
5546     We have to watch out for the "australian" case (dst starts in
5547     october, ends in april)...flagged by "reverse" and checked by
5548     scanning through the months of the previous year.
5549
5550 */
5551
5552 static int
5553 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5554 {
5555     time_t when;
5556     struct tm *w2;
5557     char *s,*s2;
5558     char *dstzone, *tz, *s_start, *s_end;
5559     int std_off, dst_off, isdst;
5560     int y, dststart, dstend;
5561     static char envtz[1025];  /* longer than any logical, symbol, ... */
5562     static char ucxtz[1025];
5563     static char reversed = 0;
5564
5565     if (!w) return 0;
5566
5567     if (tz_updated) {
5568         tz_updated = 0;
5569         reversed = -1;  /* flag need to check  */
5570         envtz[0] = ucxtz[0] = '\0';
5571         tz = my_getenv("TZ",0);
5572         if (tz) strcpy(envtz, tz);
5573         tz = my_getenv("UCX$TZ",0);
5574         if (tz) strcpy(ucxtz, tz);
5575         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
5576     }
5577     tz = envtz;
5578     if (!*tz) tz = ucxtz;
5579
5580     s = tz;
5581     while (isalpha(*s)) s++;
5582     s = tz_parse_offset(s, &std_off);
5583     if (!s) return 0;
5584     if (!*s) {                  /* no DST, hurray we're done! */
5585         isdst = 0;
5586         goto done;
5587     }
5588
5589     dstzone = s;
5590     while (isalpha(*s)) s++;
5591     s2 = tz_parse_offset(s, &dst_off);
5592     if (s2) {
5593         s = s2;
5594     } else {
5595         dst_off = std_off - 3600;
5596     }
5597
5598     if (!*s) {      /* default dst start/end?? */
5599         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
5600             s = strchr(ucxtz,',');
5601         }
5602         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
5603     }
5604     if (*s != ',') return 0;
5605
5606     when = *w;
5607     when = _toutc(when);      /* convert to utc */
5608     when = when - std_off;    /* convert to pseudolocal time*/
5609
5610     w2 = localtime(&when);
5611     y = w2->tm_year;
5612     s_start = s+1;
5613     s = tz_parse_startend(s_start,w2,&dststart);
5614     if (!s) return 0;
5615     if (*s != ',') return 0;
5616
5617     when = *w;
5618     when = _toutc(when);      /* convert to utc */
5619     when = when - dst_off;    /* convert to pseudolocal time*/
5620     w2 = localtime(&when);
5621     if (w2->tm_year != y) {   /* spans a year, just check one time */
5622         when += dst_off - std_off;
5623         w2 = localtime(&when);
5624     }
5625     s_end = s+1;
5626     s = tz_parse_startend(s_end,w2,&dstend);
5627     if (!s) return 0;
5628
5629     if (reversed == -1) {  /* need to check if start later than end */
5630         int j, ds, de;
5631
5632         when = *w;
5633         if (when < 2*365*86400) {
5634             when += 2*365*86400;
5635         } else {
5636             when -= 365*86400;
5637         }
5638         w2 =localtime(&when);
5639         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
5640
5641         for (j = 0; j < 12; j++) {
5642             w2 =localtime(&when);
5643             (void) tz_parse_startend(s_start,w2,&ds);
5644             (void) tz_parse_startend(s_end,w2,&de);
5645             if (ds != de) break;
5646             when += 30*86400;
5647         }
5648         reversed = 0;
5649         if (de && !ds) reversed = 1;
5650     }
5651
5652     isdst = dststart && !dstend;
5653     if (reversed) isdst = dststart  || !dstend;
5654
5655 done:
5656     if (dst)    *dst = isdst;
5657     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
5658     if (isdst)  tz = dstzone;
5659     if (zone) {
5660         while(isalpha(*tz))  *zone++ = *tz++;
5661         *zone = '\0';
5662     }
5663     return 1;
5664 }
5665
5666 #endif /* !RTL_USES_UTC */
5667
5668 /* my_time(), my_localtime(), my_gmtime()
5669  * By default traffic in UTC time values, using CRTL gmtime() or
5670  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5671  * Note: We need to use these functions even when the CRTL has working
5672  * UTC support, since they also handle C<use vmsish qw(times);>
5673  *
5674  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
5675  * Modified by Charles Bailey <bailey@newman.upenn.edu>
5676  */
5677
5678 /*{{{time_t my_time(time_t *timep)*/
5679 time_t Perl_my_time(pTHX_ time_t *timep)
5680 {
5681   time_t when;
5682   struct tm *tm_p;
5683
5684   if (gmtime_emulation_type == 0) {
5685     int dstnow;
5686     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
5687                               /* results of calls to gmtime() and localtime() */
5688                               /* for same &base */
5689
5690     gmtime_emulation_type++;
5691     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5692       char off[LNM$C_NAMLENGTH+1];;
5693
5694       gmtime_emulation_type++;
5695       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5696         gmtime_emulation_type++;
5697         utc_offset_secs = 0;
5698         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5699       }
5700       else { utc_offset_secs = atol(off); }
5701     }
5702     else { /* We've got a working gmtime() */
5703       struct tm gmt, local;
5704
5705       gmt = *tm_p;
5706       tm_p = localtime(&base);
5707       local = *tm_p;
5708       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
5709       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5710       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
5711       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
5712     }
5713   }
5714
5715   when = time(NULL);
5716 # ifdef VMSISH_TIME
5717 # ifdef RTL_USES_UTC
5718   if (VMSISH_TIME) when = _toloc(when);
5719 # else
5720   if (!VMSISH_TIME) when = _toutc(when);
5721 # endif
5722 # endif
5723   if (timep != NULL) *timep = when;
5724   return when;
5725
5726 }  /* end of my_time() */
5727 /*}}}*/
5728
5729
5730 /*{{{struct tm *my_gmtime(const time_t *timep)*/
5731 struct tm *
5732 Perl_my_gmtime(pTHX_ const time_t *timep)
5733 {
5734   char *p;
5735   time_t when;
5736   struct tm *rsltmp;
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
5744   when = *timep;
5745 # ifdef VMSISH_TIME
5746   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
5747 #  endif
5748 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
5749   return gmtime(&when);
5750 # else
5751   /* CRTL localtime() wants local time as input, so does no tz correction */
5752   rsltmp = localtime(&when);
5753   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
5754   return rsltmp;
5755 #endif
5756 }  /* end of my_gmtime() */
5757 /*}}}*/
5758
5759
5760 /*{{{struct tm *my_localtime(const time_t *timep)*/
5761 struct tm *
5762 Perl_my_localtime(pTHX_ const time_t *timep)
5763 {
5764   time_t when, whenutc;
5765   struct tm *rsltmp;
5766   int dst, offset;
5767
5768   if (timep == NULL) {
5769     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5770     return NULL;
5771   }
5772   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
5773   if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
5774
5775   when = *timep;
5776 # ifdef RTL_USES_UTC
5777 # ifdef VMSISH_TIME
5778   if (VMSISH_TIME) when = _toutc(when);
5779 # endif
5780   /* CRTL localtime() wants UTC as input, does tz correction itself */
5781   return localtime(&when);
5782
5783 # else /* !RTL_USES_UTC */
5784   whenutc = when;
5785 # ifdef VMSISH_TIME
5786   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
5787   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
5788 # endif
5789   dst = -1;
5790 #ifndef RTL_USES_UTC
5791   if (tz_parse(&when, &dst, 0, &offset)) {   /* truelocal determines DST*/
5792       when = whenutc - offset;                   /* pseudolocal time*/
5793   }
5794 # endif
5795   /* CRTL localtime() wants local time as input, so does no tz correction */
5796   rsltmp = localtime(&when);
5797   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
5798   return rsltmp;
5799 # endif
5800
5801 } /*  end of my_localtime() */
5802 /*}}}*/
5803
5804 /* Reset definitions for later calls */
5805 #define gmtime(t)    my_gmtime(t)
5806 #define localtime(t) my_localtime(t)
5807 #define time(t)      my_time(t)
5808
5809
5810 /* my_utime - update modification time of a file
5811  * calling sequence is identical to POSIX utime(), but under
5812  * VMS only the modification time is changed; ODS-2 does not
5813  * maintain access times.  Restrictions differ from the POSIX
5814  * definition in that the time can be changed as long as the
5815  * caller has permission to execute the necessary IO$_MODIFY $QIO;
5816  * no separate checks are made to insure that the caller is the
5817  * owner of the file or has special privs enabled.
5818  * Code here is based on Joe Meadows' FILE utility.
5819  */
5820
5821 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
5822  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
5823  * in 100 ns intervals.
5824  */
5825 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
5826
5827 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
5828 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
5829 {
5830   register int i;
5831   long int bintime[2], len = 2, lowbit, unixtime,
5832            secscale = 10000000; /* seconds --> 100 ns intervals */
5833   unsigned long int chan, iosb[2], retsts;
5834   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
5835   struct FAB myfab = cc$rms_fab;
5836   struct NAM mynam = cc$rms_nam;
5837 #if defined (__DECC) && defined (__VAX)
5838   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
5839    * at least through VMS V6.1, which causes a type-conversion warning.
5840    */
5841 #  pragma message save
5842 #  pragma message disable cvtdiftypes
5843 #endif
5844   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
5845   struct fibdef myfib;
5846 #if defined (__DECC) && defined (__VAX)
5847   /* This should be right after the declaration of myatr, but due
5848    * to a bug in VAX DEC C, this takes effect a statement early.
5849    */
5850 #  pragma message restore
5851 #endif
5852   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
5853                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
5854                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
5855
5856   if (file == NULL || *file == '\0') {
5857     set_errno(ENOENT);
5858     set_vaxc_errno(LIB$_INVARG);
5859     return -1;
5860   }
5861   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
5862
5863   if (utimes != NULL) {
5864     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
5865      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
5866      * Since time_t is unsigned long int, and lib$emul takes a signed long int
5867      * as input, we force the sign bit to be clear by shifting unixtime right
5868      * one bit, then multiplying by an extra factor of 2 in lib$emul().
5869      */
5870     lowbit = (utimes->modtime & 1) ? secscale : 0;
5871     unixtime = (long int) utimes->modtime;
5872 #   ifdef VMSISH_TIME
5873     /* If input was UTC; convert to local for sys svc */
5874     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
5875 #   endif
5876     unixtime >>= 1;  secscale <<= 1;
5877     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
5878     if (!(retsts & 1)) {
5879       set_errno(EVMSERR);
5880       set_vaxc_errno(retsts);
5881       return -1;
5882     }
5883     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
5884     if (!(retsts & 1)) {
5885       set_errno(EVMSERR);
5886       set_vaxc_errno(retsts);
5887       return -1;
5888     }
5889   }
5890   else {
5891     /* Just get the current time in VMS format directly */
5892     retsts = sys$gettim(bintime);
5893     if (!(retsts & 1)) {
5894       set_errno(EVMSERR);
5895       set_vaxc_errno(retsts);
5896       return -1;
5897     }
5898   }
5899
5900   myfab.fab$l_fna = vmsspec;
5901   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
5902   myfab.fab$l_nam = &mynam;
5903   mynam.nam$l_esa = esa;
5904   mynam.nam$b_ess = (unsigned char) sizeof esa;
5905   mynam.nam$l_rsa = rsa;
5906   mynam.nam$b_rss = (unsigned char) sizeof rsa;
5907
5908   /* Look for the file to be affected, letting RMS parse the file
5909    * specification for us as well.  I have set errno using only
5910    * values documented in the utime() man page for VMS POSIX.
5911    */
5912   retsts = sys$parse(&myfab,0,0);
5913   if (!(retsts & 1)) {
5914     set_vaxc_errno(retsts);
5915     if      (retsts == RMS$_PRV) set_errno(EACCES);
5916     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5917     else                         set_errno(EVMSERR);
5918     return -1;
5919   }
5920   retsts = sys$search(&myfab,0,0);
5921   if (!(retsts & 1)) {
5922     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
5923     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
5924     set_vaxc_errno(retsts);
5925     if      (retsts == RMS$_PRV) set_errno(EACCES);
5926     else if (retsts == RMS$_FNF) set_errno(ENOENT);
5927     else                         set_errno(EVMSERR);
5928     return -1;
5929   }
5930
5931   devdsc.dsc$w_length = mynam.nam$b_dev;
5932   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
5933
5934   retsts = sys$assign(&devdsc,&chan,0,0);
5935   if (!(retsts & 1)) {
5936     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
5937     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
5938     set_vaxc_errno(retsts);
5939     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
5940     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
5941     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
5942     else                               set_errno(EVMSERR);
5943     return -1;
5944   }
5945
5946   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
5947   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
5948
5949   memset((void *) &myfib, 0, sizeof myfib);
5950 #if defined(__DECC) || defined(__DECCXX)
5951   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
5952   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
5953   /* This prevents the revision time of the file being reset to the current
5954    * time as a result of our IO$_MODIFY $QIO. */
5955   myfib.fib$l_acctl = FIB$M_NORECORD;
5956 #else
5957   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
5958   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
5959   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
5960 #endif
5961   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
5962   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
5963   myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
5964   _ckvmssts(sys$dassgn(chan));
5965   if (retsts & 1) retsts = iosb[0];
5966   if (!(retsts & 1)) {
5967     set_vaxc_errno(retsts);
5968     if (retsts == SS$_NOPRIV) set_errno(EACCES);
5969     else                      set_errno(EVMSERR);
5970     return -1;
5971   }
5972
5973   return 0;
5974 }  /* end of my_utime() */
5975 /*}}}*/
5976
5977 /*
5978  * flex_stat, flex_fstat
5979  * basic stat, but gets it right when asked to stat
5980  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
5981  */
5982
5983 /* encode_dev packs a VMS device name string into an integer to allow
5984  * simple comparisons. This can be used, for example, to check whether two
5985  * files are located on the same device, by comparing their encoded device
5986  * names. Even a string comparison would not do, because stat() reuses the
5987  * device name buffer for each call; so without encode_dev, it would be
5988  * necessary to save the buffer and use strcmp (this would mean a number of
5989  * changes to the standard Perl code, to say nothing of what a Perl script
5990  * would have to do.
5991  *
5992  * The device lock id, if it exists, should be unique (unless perhaps compared
5993  * with lock ids transferred from other nodes). We have a lock id if the disk is
5994  * mounted cluster-wide, which is when we tend to get long (host-qualified)
5995  * device names. Thus we use the lock id in preference, and only if that isn't
5996  * available, do we try to pack the device name into an integer (flagged by
5997  * the sign bit (LOCKID_MASK) being set).
5998  *
5999  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6000  * name and its encoded form, but it seems very unlikely that we will find
6001  * two files on different disks that share the same encoded device names,
6002  * and even more remote that they will share the same file id (if the test
6003  * is to check for the same file).
6004  *
6005  * A better method might be to use sys$device_scan on the first call, and to
6006  * search for the device, returning an index into the cached array.
6007  * The number returned would be more intelligable.
6008  * This is probably not worth it, and anyway would take quite a bit longer
6009  * on the first call.
6010  */
6011 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
6012 static mydev_t encode_dev (pTHX_ const char *dev)
6013 {
6014   int i;
6015   unsigned long int f;
6016   mydev_t enc;
6017   char c;
6018   const char *q;
6019
6020   if (!dev || !dev[0]) return 0;
6021
6022 #if LOCKID_MASK
6023   {
6024     struct dsc$descriptor_s dev_desc;
6025     unsigned long int status, lockid, item = DVI$_LOCKID;
6026
6027     /* For cluster-mounted disks, the disk lock identifier is unique, so we
6028        can try that first. */
6029     dev_desc.dsc$w_length =  strlen (dev);
6030     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
6031     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
6032     dev_desc.dsc$a_pointer = (char *) dev;
6033     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6034     if (lockid) return (lockid & ~LOCKID_MASK);
6035   }
6036 #endif
6037
6038   /* Otherwise we try to encode the device name */
6039   enc = 0;
6040   f = 1;
6041   i = 0;
6042   for (q = dev + strlen(dev); q--; q >= dev) {
6043     if (isdigit (*q))
6044       c= (*q) - '0';
6045     else if (isalpha (toupper (*q)))
6046       c= toupper (*q) - 'A' + (char)10;
6047     else
6048       continue; /* Skip '$'s */
6049     i++;
6050     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
6051     if (i>1) f *= 36;
6052     enc += f * (unsigned long int) c;
6053   }
6054   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
6055
6056 }  /* end of encode_dev() */
6057
6058 static char namecache[NAM$C_MAXRSS+1];
6059
6060 static int
6061 is_null_device(name)
6062     const char *name;
6063 {
6064     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6065        The underscore prefix, controller letter, and unit number are
6066        independently optional; for our purposes, the colon punctuation
6067        is not.  The colon can be trailed by optional directory and/or
6068        filename, but two consecutive colons indicates a nodename rather
6069        than a device.  [pr]  */
6070   if (*name == '_') ++name;
6071   if (tolower(*name++) != 'n') return 0;
6072   if (tolower(*name++) != 'l') return 0;
6073   if (tolower(*name) == 'a') ++name;
6074   if (*name == '0') ++name;
6075   return (*name++ == ':') && (*name != ':');
6076 }
6077
6078 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
6079 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6080  * subset of the applicable information.
6081  */
6082 bool
6083 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6084 {
6085   char fname_phdev[NAM$C_MAXRSS+1];
6086   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6087   else {
6088     char fname[NAM$C_MAXRSS+1];
6089     unsigned long int retsts;
6090     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6091                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6092
6093     /* If the struct mystat is stale, we're OOL; stat() overwrites the
6094        device name on successive calls */
6095     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6096     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6097     namdsc.dsc$a_pointer = fname;
6098     namdsc.dsc$w_length = sizeof fname - 1;
6099
6100     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6101                              &namdsc,&namdsc.dsc$w_length,0,0);
6102     if (retsts & 1) {
6103       fname[namdsc.dsc$w_length] = '\0';
6104 /*
6105  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6106  * but if someone has redefined that logical, Perl gets very lost.  Since
6107  * we have the physical device name from the stat buffer, just paste it on.
6108  */
6109       strcpy( fname_phdev, statbufp->st_devnam );
6110       strcat( fname_phdev, strrchr(fname, ':') );
6111
6112       return cando_by_name(bit,effective,fname_phdev);
6113     }
6114     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6115       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6116       return FALSE;
6117     }
6118     _ckvmssts(retsts);
6119     return FALSE;  /* Should never get to here */
6120   }
6121 }  /* end of cando() */
6122 /*}}}*/
6123
6124
6125 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6126 I32
6127 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6128 {
6129   static char usrname[L_cuserid];
6130   static struct dsc$descriptor_s usrdsc =
6131          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6132   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6133   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6134   unsigned short int retlen;
6135   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6136   union prvdef curprv;
6137   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6138          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6139   struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6140          {0,0,0,0}};
6141
6142   if (!fname || !*fname) return FALSE;
6143   /* Make sure we expand logical names, since sys$check_access doesn't */
6144   if (!strpbrk(fname,"/]>:")) {
6145     strcpy(fileified,fname);
6146     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6147     fname = fileified;
6148   }
6149   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6150   retlen = namdsc.dsc$w_length = strlen(vmsname);
6151   namdsc.dsc$a_pointer = vmsname;
6152   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6153       vmsname[retlen-1] == ':') {
6154     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6155     namdsc.dsc$w_length = strlen(fileified);
6156     namdsc.dsc$a_pointer = fileified;
6157   }
6158
6159   if (!usrdsc.dsc$w_length) {
6160     cuserid(usrname);
6161     usrdsc.dsc$w_length = strlen(usrname);
6162   }
6163
6164   switch (bit) {
6165     case S_IXUSR: case S_IXGRP: case S_IXOTH:
6166       access = ARM$M_EXECUTE; break;
6167     case S_IRUSR: case S_IRGRP: case S_IROTH:
6168       access = ARM$M_READ; break;
6169     case S_IWUSR: case S_IWGRP: case S_IWOTH:
6170       access = ARM$M_WRITE; break;
6171     case S_IDUSR: case S_IDGRP: case S_IDOTH:
6172       access = ARM$M_DELETE; break;
6173     default:
6174       return FALSE;
6175   }
6176
6177   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6178   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
6179       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6180       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6181     set_vaxc_errno(retsts);
6182     if (retsts == SS$_NOPRIV) set_errno(EACCES);
6183     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6184     else set_errno(ENOENT);
6185     return FALSE;
6186   }
6187   if (retsts == SS$_NORMAL) {
6188     if (!privused) return TRUE;
6189     /* We can get access, but only by using privs.  Do we have the
6190        necessary privs currently enabled? */
6191     _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6192     if ((privused & CHP$M_BYPASS) &&  !curprv.prv$v_bypass)  return FALSE;
6193     if ((privused & CHP$M_SYSPRV) &&  !curprv.prv$v_sysprv &&
6194                                       !curprv.prv$v_bypass)  return FALSE;
6195     if ((privused & CHP$M_GRPPRV) &&  !curprv.prv$v_grpprv &&
6196          !curprv.prv$v_sysprv &&      !curprv.prv$v_bypass)  return FALSE;
6197     if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6198     return TRUE;
6199   }
6200   if (retsts == SS$_ACCONFLICT) {
6201     return TRUE;
6202   }
6203   _ckvmssts(retsts);
6204
6205   return FALSE;  /* Should never get here */
6206
6207 }  /* end of cando_by_name() */
6208 /*}}}*/
6209
6210
6211 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6212 int
6213 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6214 {
6215   if (!fstat(fd,(stat_t *) statbufp)) {
6216     if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6217     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6218 #   ifdef RTL_USES_UTC
6219 #   ifdef VMSISH_TIME
6220     if (VMSISH_TIME) {
6221       statbufp->st_mtime = _toloc(statbufp->st_mtime);
6222       statbufp->st_atime = _toloc(statbufp->st_atime);
6223       statbufp->st_ctime = _toloc(statbufp->st_ctime);
6224     }
6225 #   endif
6226 #   else
6227 #   ifdef VMSISH_TIME
6228     if (!VMSISH_TIME) { /* Return UTC instead of local time */
6229 #   else
6230     if (1) {
6231 #   endif
6232       statbufp->st_mtime = _toutc(statbufp->st_mtime);
6233       statbufp->st_atime = _toutc(statbufp->st_atime);
6234       statbufp->st_ctime = _toutc(statbufp->st_ctime);
6235     }
6236 #endif
6237     return 0;
6238   }
6239   return -1;
6240
6241 }  /* end of flex_fstat() */
6242 /*}}}*/
6243
6244 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6245 int
6246 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6247 {
6248     char fileified[NAM$C_MAXRSS+1];
6249     char temp_fspec[NAM$C_MAXRSS+300];
6250     int retval = -1;
6251
6252     strcpy(temp_fspec, fspec);
6253     if (statbufp == (Stat_t *) &PL_statcache)
6254       do_tovmsspec(temp_fspec,namecache,0);
6255     if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6256       memset(statbufp,0,sizeof *statbufp);
6257       statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6258       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6259       statbufp->st_uid = 0x00010001;
6260       statbufp->st_gid = 0x0001;
6261       time((time_t *)&statbufp->st_mtime);
6262       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6263       return 0;
6264     }
6265
6266     /* Try for a directory name first.  If fspec contains a filename without
6267      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6268      * and sea:[wine.dark]water. exist, we prefer the directory here.
6269      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6270      * not sea:[wine.dark]., if the latter exists.  If the intended target is
6271      * the file with null type, specify this by calling flex_stat() with
6272      * a '.' at the end of fspec.
6273      */
6274     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6275       retval = stat(fileified,(stat_t *) statbufp);
6276       if (!retval && statbufp == (Stat_t *) &PL_statcache)
6277         strcpy(namecache,fileified);
6278     }
6279     if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6280     if (!retval) {
6281       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6282 #     ifdef RTL_USES_UTC
6283 #     ifdef VMSISH_TIME
6284       if (VMSISH_TIME) {
6285         statbufp->st_mtime = _toloc(statbufp->st_mtime);
6286         statbufp->st_atime = _toloc(statbufp->st_atime);
6287         statbufp->st_ctime = _toloc(statbufp->st_ctime);
6288       }
6289 #     endif
6290 #     else
6291 #     ifdef VMSISH_TIME
6292       if (!VMSISH_TIME) { /* Return UTC instead of local time */
6293 #     else
6294       if (1) {
6295 #     endif
6296         statbufp->st_mtime = _toutc(statbufp->st_mtime);
6297         statbufp->st_atime = _toutc(statbufp->st_atime);
6298         statbufp->st_ctime = _toutc(statbufp->st_ctime);
6299       }
6300 #     endif
6301     }
6302     return retval;
6303
6304 }  /* end of flex_stat() */
6305 /*}}}*/
6306
6307
6308 /*{{{char *my_getlogin()*/
6309 /* VMS cuserid == Unix getlogin, except calling sequence */
6310 char *
6311 my_getlogin()
6312 {
6313     static char user[L_cuserid];
6314     return cuserid(user);
6315 }
6316 /*}}}*/
6317
6318
6319 /*  rmscopy - copy a file using VMS RMS routines
6320  *
6321  *  Copies contents and attributes of spec_in to spec_out, except owner
6322  *  and protection information.  Name and type of spec_in are used as
6323  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
6324  *  should try to propagate timestamps from the input file to the output file.
6325  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
6326  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
6327  *  propagated to the output file at creation iff the output file specification
6328  *  did not contain an explicit name or type, and the revision date is always
6329  *  updated at the end of the copy operation.  If it is greater than 0, then
6330  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6331  *  other than the revision date should be propagated, and bit 1 indicates
6332  *  that the revision date should be propagated.
6333  *
6334  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6335  *
6336  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6337  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
6338  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
6339  * as part of the Perl standard distribution under the terms of the
6340  * GNU General Public License or the Perl Artistic License.  Copies
6341  * of each may be found in the Perl standard distribution.
6342  */
6343 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6344 int
6345 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6346 {
6347     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6348          rsa[NAM$C_MAXRSS], ubf[32256];
6349     unsigned long int i, sts, sts2;
6350     struct FAB fab_in, fab_out;
6351     struct RAB rab_in, rab_out;
6352     struct NAM nam;
6353     struct XABDAT xabdat;
6354     struct XABFHC xabfhc;
6355     struct XABRDT xabrdt;
6356     struct XABSUM xabsum;
6357
6358     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
6359         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6360       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6361       return 0;
6362     }
6363
6364     fab_in = cc$rms_fab;
6365     fab_in.fab$l_fna = vmsin;
6366     fab_in.fab$b_fns = strlen(vmsin);
6367     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6368     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6369     fab_in.fab$l_fop = FAB$M_SQO;
6370     fab_in.fab$l_nam =  &nam;
6371     fab_in.fab$l_xab = (void *) &xabdat;
6372
6373     nam = cc$rms_nam;
6374     nam.nam$l_rsa = rsa;
6375     nam.nam$b_rss = sizeof(rsa);
6376     nam.nam$l_esa = esa;
6377     nam.nam$b_ess = sizeof (esa);
6378     nam.nam$b_esl = nam.nam$b_rsl = 0;
6379
6380     xabdat = cc$rms_xabdat;        /* To get creation date */
6381     xabdat.xab$l_nxt = (void *) &xabfhc;
6382
6383     xabfhc = cc$rms_xabfhc;        /* To get record length */
6384     xabfhc.xab$l_nxt = (void *) &xabsum;
6385
6386     xabsum = cc$rms_xabsum;        /* To get key and area information */
6387
6388     if (!((sts = sys$open(&fab_in)) & 1)) {
6389       set_vaxc_errno(sts);
6390       switch (sts) {
6391         case RMS$_FNF: case RMS$_DNF:
6392           set_errno(ENOENT); break;
6393         case RMS$_DIR:
6394           set_errno(ENOTDIR); break;
6395         case RMS$_DEV:
6396           set_errno(ENODEV); break;
6397         case RMS$_SYN:
6398           set_errno(EINVAL); break;
6399         case RMS$_PRV:
6400           set_errno(EACCES); break;
6401         default:
6402           set_errno(EVMSERR);
6403       }
6404       return 0;
6405     }
6406
6407     fab_out = fab_in;
6408     fab_out.fab$w_ifi = 0;
6409     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6410     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6411     fab_out.fab$l_fop = FAB$M_SQO;
6412     fab_out.fab$l_fna = vmsout;
6413     fab_out.fab$b_fns = strlen(vmsout);
6414     fab_out.fab$l_dna = nam.nam$l_name;
6415     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6416
6417     if (preserve_dates == 0) {  /* Act like DCL COPY */
6418       nam.nam$b_nop = NAM$M_SYNCHK;
6419       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
6420       if (!((sts = sys$parse(&fab_out)) & 1)) {
6421         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6422         set_vaxc_errno(sts);
6423         return 0;
6424       }
6425       fab_out.fab$l_xab = (void *) &xabdat;
6426       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6427     }
6428     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
6429     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
6430       preserve_dates =0;      /* bitmask from this point forward   */
6431
6432     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6433     if (!((sts = sys$create(&fab_out)) & 1)) {
6434       set_vaxc_errno(sts);
6435       switch (sts) {
6436         case RMS$_DNF:
6437           set_errno(ENOENT); break;
6438         case RMS$_DIR:
6439           set_errno(ENOTDIR); break;
6440         case RMS$_DEV:
6441           set_errno(ENODEV); break;
6442         case RMS$_SYN:
6443           set_errno(EINVAL); break;
6444         case RMS$_PRV:
6445           set_errno(EACCES); break;
6446         default:
6447           set_errno(EVMSERR);
6448       }
6449       return 0;
6450     }
6451     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
6452     if (preserve_dates & 2) {
6453       /* sys$close() will process xabrdt, not xabdat */
6454       xabrdt = cc$rms_xabrdt;
6455 #ifndef __GNUC__
6456       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6457 #else
6458       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6459        * is unsigned long[2], while DECC & VAXC use a struct */
6460       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6461 #endif
6462       fab_out.fab$l_xab = (void *) &xabrdt;
6463     }
6464
6465     rab_in = cc$rms_rab;
6466     rab_in.rab$l_fab = &fab_in;
6467     rab_in.rab$l_rop = RAB$M_BIO;
6468     rab_in.rab$l_ubf = ubf;
6469     rab_in.rab$w_usz = sizeof ubf;
6470     if (!((sts = sys$connect(&rab_in)) & 1)) {
6471       sys$close(&fab_in); sys$close(&fab_out);
6472       set_errno(EVMSERR); set_vaxc_errno(sts);
6473       return 0;
6474     }
6475
6476     rab_out = cc$rms_rab;
6477     rab_out.rab$l_fab = &fab_out;
6478     rab_out.rab$l_rbf = ubf;
6479     if (!((sts = sys$connect(&rab_out)) & 1)) {
6480       sys$close(&fab_in); sys$close(&fab_out);
6481       set_errno(EVMSERR); set_vaxc_errno(sts);
6482       return 0;
6483     }
6484
6485     while ((sts = sys$read(&rab_in))) {  /* always true  */
6486       if (sts == RMS$_EOF) break;
6487       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6488       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6489         sys$close(&fab_in); sys$close(&fab_out);
6490         set_errno(EVMSERR); set_vaxc_errno(sts);
6491         return 0;
6492       }
6493     }
6494
6495     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
6496     sys$close(&fab_in);  sys$close(&fab_out);
6497     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6498     if (!(sts & 1)) {
6499       set_errno(EVMSERR); set_vaxc_errno(sts);
6500       return 0;
6501     }
6502
6503     return 1;
6504
6505 }  /* end of rmscopy() */
6506 /*}}}*/
6507
6508
6509 /***  The following glue provides 'hooks' to make some of the routines
6510  * from this file available from Perl.  These routines are sufficiently
6511  * basic, and are required sufficiently early in the build process,
6512  * that's it's nice to have them available to miniperl as well as the
6513  * full Perl, so they're set up here instead of in an extension.  The
6514  * Perl code which handles importation of these names into a given
6515  * package lives in [.VMS]Filespec.pm in @INC.
6516  */
6517
6518 void
6519 rmsexpand_fromperl(pTHX_ CV *cv)
6520 {
6521   dXSARGS;
6522   char *fspec, *defspec = NULL, *rslt;
6523   STRLEN n_a;
6524
6525   if (!items || items > 2)
6526     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6527   fspec = SvPV(ST(0),n_a);
6528   if (!fspec || !*fspec) XSRETURN_UNDEF;
6529   if (items == 2) defspec = SvPV(ST(1),n_a);
6530
6531   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6532   ST(0) = sv_newmortal();
6533   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6534   XSRETURN(1);
6535 }
6536
6537 void
6538 vmsify_fromperl(pTHX_ CV *cv)
6539 {
6540   dXSARGS;
6541   char *vmsified;
6542   STRLEN n_a;
6543
6544   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6545   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6546   ST(0) = sv_newmortal();
6547   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6548   XSRETURN(1);
6549 }
6550
6551 void
6552 unixify_fromperl(pTHX_ CV *cv)
6553 {
6554   dXSARGS;
6555   char *unixified;
6556   STRLEN n_a;
6557
6558   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6559   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6560   ST(0) = sv_newmortal();
6561   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6562   XSRETURN(1);
6563 }
6564
6565 void
6566 fileify_fromperl(pTHX_ CV *cv)
6567 {
6568   dXSARGS;
6569   char *fileified;
6570   STRLEN n_a;
6571
6572   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6573   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6574   ST(0) = sv_newmortal();
6575   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6576   XSRETURN(1);
6577 }
6578
6579 void
6580 pathify_fromperl(pTHX_ CV *cv)
6581 {
6582   dXSARGS;
6583   char *pathified;
6584   STRLEN n_a;
6585
6586   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6587   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6588   ST(0) = sv_newmortal();
6589   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6590   XSRETURN(1);
6591 }
6592
6593 void
6594 vmspath_fromperl(pTHX_ CV *cv)
6595 {
6596   dXSARGS;
6597   char *vmspath;
6598   STRLEN n_a;
6599
6600   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6601   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6602   ST(0) = sv_newmortal();
6603   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6604   XSRETURN(1);
6605 }
6606
6607 void
6608 unixpath_fromperl(pTHX_ CV *cv)
6609 {
6610   dXSARGS;
6611   char *unixpath;
6612   STRLEN n_a;
6613
6614   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6615   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6616   ST(0) = sv_newmortal();
6617   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6618   XSRETURN(1);
6619 }
6620
6621 void
6622 candelete_fromperl(pTHX_ CV *cv)
6623 {
6624   dXSARGS;
6625   char fspec[NAM$C_MAXRSS+1], *fsp;
6626   SV *mysv;
6627   IO *io;
6628   STRLEN n_a;
6629
6630   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6631
6632   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6633   if (SvTYPE(mysv) == SVt_PVGV) {
6634     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
6635       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6636       ST(0) = &PL_sv_no;
6637       XSRETURN(1);
6638     }
6639     fsp = fspec;
6640   }
6641   else {
6642     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6643       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6644       ST(0) = &PL_sv_no;
6645       XSRETURN(1);
6646     }
6647   }
6648
6649   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6650   XSRETURN(1);
6651 }
6652
6653 void
6654 rmscopy_fromperl(pTHX_ CV *cv)
6655 {
6656   dXSARGS;
6657   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6658   int date_flag;
6659   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6660                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6661   unsigned long int sts;
6662   SV *mysv;
6663   IO *io;
6664   STRLEN n_a;
6665
6666   if (items < 2 || items > 3)
6667     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6668
6669   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6670   if (SvTYPE(mysv) == SVt_PVGV) {
6671     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
6672       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6673       ST(0) = &PL_sv_no;
6674       XSRETURN(1);
6675     }
6676     inp = inspec;
6677   }
6678   else {
6679     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6680       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6681       ST(0) = &PL_sv_no;
6682       XSRETURN(1);
6683     }
6684   }
6685   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6686   if (SvTYPE(mysv) == SVt_PVGV) {
6687     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
6688       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6689       ST(0) = &PL_sv_no;
6690       XSRETURN(1);
6691     }
6692     outp = outspec;
6693   }
6694   else {
6695     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6696       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6697       ST(0) = &PL_sv_no;
6698       XSRETURN(1);
6699     }
6700   }
6701   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6702
6703   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6704   XSRETURN(1);
6705 }
6706
6707
6708 void
6709 mod2fname(pTHX_ CV *cv)
6710 {
6711   dXSARGS;
6712   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6713        workbuff[NAM$C_MAXRSS*1 + 1];
6714   int total_namelen = 3, counter, num_entries;
6715   /* ODS-5 ups this, but we want to be consistent, so... */
6716   int max_name_len = 39;
6717   AV *in_array = (AV *)SvRV(ST(0));
6718
6719   num_entries = av_len(in_array);
6720
6721   /* All the names start with PL_. */
6722   strcpy(ultimate_name, "PL_");
6723
6724   /* Clean up our working buffer */
6725   Zero(work_name, sizeof(work_name), char);
6726
6727   /* Run through the entries and build up a working name */
6728   for(counter = 0; counter <= num_entries; counter++) {
6729     /* If it's not the first name then tack on a __ */
6730     if (counter) {
6731       strcat(work_name, "__");
6732     }
6733     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
6734                            PL_na));
6735   }
6736
6737   /* Check to see if we actually have to bother...*/
6738   if (strlen(work_name) + 3 <= max_name_len) {
6739     strcat(ultimate_name, work_name);
6740   } else {
6741     /* It's too darned big, so we need to go strip. We use the same */
6742     /* algorithm as xsubpp does. First, strip out doubled __ */
6743     char *source, *dest, last;
6744     dest = workbuff;
6745     last = 0;
6746     for (source = work_name; *source; source++) {
6747       if (last == *source && last == '_') {
6748         continue;
6749       }
6750       *dest++ = *source;
6751       last = *source;
6752     }
6753     /* Go put it back */
6754     strcpy(work_name, workbuff);
6755     /* Is it still too big? */
6756     if (strlen(work_name) + 3 > max_name_len) {
6757       /* Strip duplicate letters */
6758       last = 0;
6759       dest = workbuff;
6760       for (source = work_name; *source; source++) {
6761         if (last == toupper(*source)) {
6762         continue;
6763         }
6764         *dest++ = *source;
6765         last = toupper(*source);
6766       }
6767       strcpy(work_name, workbuff);
6768     }
6769
6770     /* Is it *still* too big? */
6771     if (strlen(work_name) + 3 > max_name_len) {
6772       /* Too bad, we truncate */
6773       work_name[max_name_len - 2] = 0;
6774     }
6775     strcat(ultimate_name, work_name);
6776   }
6777
6778   /* Okay, return it */
6779   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
6780   XSRETURN(1);
6781 }
6782
6783 void
6784 init_os_extras()
6785 {
6786   dTHX;
6787   char* file = __FILE__;
6788   char temp_buff[512];
6789   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
6790     no_translate_barewords = TRUE;
6791   } else {
6792     no_translate_barewords = FALSE;
6793   }
6794
6795   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
6796   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
6797   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
6798   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
6799   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
6800   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
6801   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
6802   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
6803   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
6804   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
6805
6806   store_pipelocs(aTHX);
6807
6808   return;
6809 }
6810
6811 /*  End of vms.c */