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