vms/vms.c

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