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