vms/vms.c

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