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
3345     if (!dir || !*dir) {
3346       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3347     }
3348
3349     if (*dir) strcpy(trndir,dir);
3350     else getcwd(trndir,sizeof trndir - 1);
3351
3352     trnlnm_iter_count = 0;
3353     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3354            && my_trnlnm(trndir,trndir,0)) {
3355       trnlnm_iter_count++;
3356       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3357       STRLEN trnlen = strlen(trndir);
3358
3359       /* Trap simple rooted lnms, and return lnm:[000000] */
3360       if (!strcmp(trndir+trnlen-2,".]")) {
3361         if (buf) retpath = buf;
3362         else if (ts) New(1318,retpath,strlen(dir)+10,char);
3363         else retpath = __pathify_retbuf;
3364         strcpy(retpath,dir);
3365         strcat(retpath,":[000000]");
3366         return retpath;
3367       }
3368     }
3369     dir = trndir;
3370
3371     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3372       if (*dir == '.' && (*(dir+1) == '\0' ||
3373                           (*(dir+1) == '.' && *(dir+2) == '\0')))
3374         retlen = 2 + (*(dir+1) != '\0');
3375       else {
3376         if ( !(cp1 = strrchr(dir,'/')) &&
3377              !(cp1 = strrchr(dir,']')) &&
3378              !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3379         if ((cp2 = strchr(cp1,'.')) != NULL &&
3380             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
3381              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
3382               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3383               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3384           int ver; char *cp3;
3385           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3386               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3387               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3388               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3389               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3390                             (ver || *cp3)))))) {
3391             set_errno(ENOTDIR);
3392             set_vaxc_errno(RMS$_DIR);
3393             return NULL;
3394           }
3395           retlen = cp2 - dir + 1;
3396         }
3397         else {  /* No file type present.  Treat the filename as a directory. */
3398           retlen = strlen(dir) + 1;
3399         }
3400       }
3401       if (buf) retpath = buf;
3402       else if (ts) New(1313,retpath,retlen+1,char);
3403       else retpath = __pathify_retbuf;
3404       strncpy(retpath,dir,retlen-1);
3405       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3406         retpath[retlen-1] = '/';      /* with '/', add it. */
3407         retpath[retlen] = '\0';
3408       }
3409       else retpath[retlen-1] = '\0';
3410     }
3411     else {  /* VMS-style directory spec */
3412       char esa[NAM$C_MAXRSS+1], *cp;
3413       unsigned long int sts, cmplen, haslower;
3414       struct FAB dirfab = cc$rms_fab;
3415       struct NAM savnam, dirnam = cc$rms_nam;
3416
3417       /* If we've got an explicit filename, we can just shuffle the string. */
3418       if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3419              (cp1 = strrchr(dir,'>')) != NULL     ) && *(cp1+1)) {
3420         if ((cp2 = strchr(cp1,'.')) != NULL) {
3421           int ver; char *cp3;
3422           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3423               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3424               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3425               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3426               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3427                             (ver || *cp3)))))) {
3428             set_errno(ENOTDIR);
3429             set_vaxc_errno(RMS$_DIR);
3430             return NULL;
3431           }
3432         }
3433         else {  /* No file type, so just draw name into directory part */
3434           for (cp2 = cp1; *cp2; cp2++) ;
3435         }
3436         *cp2 = *cp1;
3437         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
3438         *cp1 = '.';
3439         /* We've now got a VMS 'path'; fall through */
3440       }
3441       dirfab.fab$b_fns = strlen(dir);
3442       dirfab.fab$l_fna = dir;
3443       if (dir[dirfab.fab$b_fns-1] == ']' ||
3444           dir[dirfab.fab$b_fns-1] == '>' ||
3445           dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3446         if (buf) retpath = buf;
3447         else if (ts) New(1314,retpath,strlen(dir)+1,char);
3448         else retpath = __pathify_retbuf;
3449         strcpy(retpath,dir);
3450         return retpath;
3451       }
3452       dirfab.fab$l_dna = ".DIR;1";
3453       dirfab.fab$b_dns = 6;
3454       dirfab.fab$l_nam = &dirnam;
3455       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3456       dirnam.nam$l_esa = esa;
3457
3458       for (cp = dir; *cp; cp++)
3459         if (islower(*cp)) { haslower = 1; break; }
3460
3461       if (!(sts = (sys$parse(&dirfab)&1))) {
3462         if (dirfab.fab$l_sts == RMS$_DIR) {
3463           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3464           sts = sys$parse(&dirfab) & 1;
3465         }
3466         if (!sts) {
3467           set_errno(EVMSERR);
3468           set_vaxc_errno(dirfab.fab$l_sts);
3469           return NULL;
3470         }
3471       }
3472       else {
3473         savnam = dirnam;
3474         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
3475           if (dirfab.fab$l_sts != RMS$_FNF) {
3476             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3477             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3478             set_errno(EVMSERR);
3479             set_vaxc_errno(dirfab.fab$l_sts);
3480             return NULL;
3481           }
3482           dirnam = savnam; /* No; just work with potential name */
3483         }
3484       }
3485       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3486         /* Yep; check version while we're at it, if it's there. */
3487         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3488         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3489           /* Something other than .DIR[;1].  Bzzt. */
3490           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3491           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3492           set_errno(ENOTDIR);
3493           set_vaxc_errno(RMS$_DIR);
3494           return NULL;
3495         }
3496       }
3497       /* OK, the type was fine.  Now pull any file name into the
3498          directory path. */
3499       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3500       else {
3501         cp1 = strrchr(esa,'>');
3502         *dirnam.nam$l_type = '>';
3503       }
3504       *cp1 = '.';
3505       *(dirnam.nam$l_type + 1) = '\0';
3506       retlen = dirnam.nam$l_type - esa + 2;
3507       if (buf) retpath = buf;
3508       else if (ts) New(1314,retpath,retlen,char);
3509       else retpath = __pathify_retbuf;
3510       strcpy(retpath,esa);
3511       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3512       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3513       /* $PARSE may have upcased filespec, so convert output to lower
3514        * case if input contained any lowercase characters. */
3515       if (haslower) __mystrtolower(retpath);
3516     }
3517
3518     return retpath;
3519 }  /* end of do_pathify_dirspec() */
3520 /*}}}*/
3521 /* External entry points */
3522 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3523 { return do_pathify_dirspec(dir,buf,0); }
3524 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3525 { return do_pathify_dirspec(dir,buf,1); }
3526
3527 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3528 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3529 {
3530   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3531   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3532   int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3533   unsigned short int trnlnm_iter_count;
3534
3535   if (spec == NULL) return NULL;
3536   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3537   if (buf) rslt = buf;
3538   else if (ts) {
3539     retlen = strlen(spec);
3540     cp1 = strchr(spec,'[');
3541     if (!cp1) cp1 = strchr(spec,'<');
3542     if (cp1) {
3543       for (cp1++; *cp1; cp1++) {
3544         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
3545         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3546           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3547       }
3548     }
3549     New(1315,rslt,retlen+2+2*expand,char);
3550   }
3551   else rslt = __tounixspec_retbuf;
3552   if (strchr(spec,'/') != NULL) {
3553     strcpy(rslt,spec);
3554     return rslt;
3555   }
3556
3557   cp1 = rslt;
3558   cp2 = spec;
3559   dirend = strrchr(spec,']');
3560   if (dirend == NULL) dirend = strrchr(spec,'>');
3561   if (dirend == NULL) dirend = strchr(spec,':');
3562   if (dirend == NULL) {
3563     strcpy(rslt,spec);
3564     return rslt;
3565   }
3566   if (*cp2 != '[' && *cp2 != '<') {
3567     *(cp1++) = '/';
3568   }
3569   else {  /* the VMS spec begins with directories */
3570     cp2++;
3571     if (*cp2 == ']' || *cp2 == '>') {
3572       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3573       return rslt;
3574     }
3575     else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3576       if (getcwd(tmp,sizeof tmp,1) == NULL) {
3577         if (ts) Safefree(rslt);
3578         return NULL;
3579       }
3580       trnlnm_iter_count = 0;
3581       do {
3582         cp3 = tmp;
3583         while (*cp3 != ':' && *cp3) cp3++;
3584         *(cp3++) = '\0';
3585         if (strchr(cp3,']') != NULL) break;
3586         trnlnm_iter_count++;
3587         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
3588       } while (vmstrnenv(tmp,tmp,0,fildev,0));
3589       if (ts && !buf &&
3590           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3591         retlen = devlen + dirlen;
3592         Renew(rslt,retlen+1+2*expand,char);
3593         cp1 = rslt;
3594       }
3595       cp3 = tmp;
3596       *(cp1++) = '/';
3597       while (*cp3) {
3598         *(cp1++) = *(cp3++);
3599         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3600       }
3601       *(cp1++) = '/';
3602     }
3603     else if ( *cp2 == '.') {
3604       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3605         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3606         cp2 += 3;
3607       }
3608       else cp2++;
3609     }
3610   }
3611   for (; cp2 <= dirend; cp2++) {
3612     if (*cp2 == ':') {
3613       *(cp1++) = '/';
3614       if (*(cp2+1) == '[') cp2++;
3615     }
3616     else if (*cp2 == ']' || *cp2 == '>') {
3617       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3618     }
3619     else if (*cp2 == '.') {
3620       *(cp1++) = '/';
3621       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3622         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3623                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3624         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3625             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3626       }
3627       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3628         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3629         cp2 += 2;
3630       }
3631     }
3632     else if (*cp2 == '-') {
3633       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3634         while (*cp2 == '-') {
3635           cp2++;
3636           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3637         }
3638         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3639           if (ts) Safefree(rslt);                        /* filespecs like */
3640           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
3641           return NULL;
3642         }
3643       }
3644       else *(cp1++) = *cp2;
3645     }
3646     else *(cp1++) = *cp2;
3647   }
3648   while (*cp2) *(cp1++) = *(cp2++);
3649   *cp1 = '\0';
3650
3651   return rslt;
3652
3653 }  /* end of do_tounixspec() */
3654 /*}}}*/
3655 /* External entry points */
3656 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3657 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3658
3659 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3660 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3661   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3662   char *rslt, *dirend;
3663   register char *cp1, *cp2;
3664   unsigned long int infront = 0, hasdir = 1;
3665
3666   if (path == NULL) return NULL;
3667   if (buf) rslt = buf;
3668   else if (ts) New(1316,rslt,strlen(path)+9,char);
3669   else rslt = __tovmsspec_retbuf;
3670   if (strpbrk(path,"]:>") ||
3671       (dirend = strrchr(path,'/')) == NULL) {
3672     if (path[0] == '.') {
3673       if (path[1] == '\0') strcpy(rslt,"[]");
3674       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3675       else strcpy(rslt,path); /* probably garbage */
3676     }
3677     else strcpy(rslt,path);
3678     return rslt;
3679   }
3680   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
3681     if (!*(dirend+2)) dirend +=2;
3682     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3683     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3684   }
3685   cp1 = rslt;
3686   cp2 = path;
3687   if (*cp2 == '/') {
3688     char trndev[NAM$C_MAXRSS+1];
3689     int islnm, rooted;
3690     STRLEN trnend;
3691
3692     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
3693     if (!*(cp2+1)) {
3694       if (!buf & ts) Renew(rslt,18,char);
3695       strcpy(rslt,"sys$disk:[000000]");
3696       return rslt;
3697     }
3698     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3699     *cp1 = '\0';
3700     islnm =  my_trnlnm(rslt,trndev,0);
3701     trnend = islnm ? strlen(trndev) - 1 : 0;
3702     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3703     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3704     /* If the first element of the path is a logical name, determine
3705      * whether it has to be translated so we can add more directories. */
3706     if (!islnm || rooted) {
3707       *(cp1++) = ':';
3708       *(cp1++) = '[';
3709       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3710       else cp2++;
3711     }
3712     else {
3713       if (cp2 != dirend) {
3714         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3715         strcpy(rslt,trndev);
3716         cp1 = rslt + trnend;
3717         *(cp1++) = '.';
3718         cp2++;
3719       }
3720       else {
3721         *(cp1++) = ':';
3722         hasdir = 0;
3723       }
3724     }
3725   }
3726   else {
3727     *(cp1++) = '[';
3728     if (*cp2 == '.') {
3729       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3730         cp2 += 2;         /* skip over "./" - it's redundant */
3731         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
3732       }
3733       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3734         *(cp1++) = '-';                                 /* "../" --> "-" */
3735         cp2 += 3;
3736       }
3737       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3738                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3739         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3740         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3741         cp2 += 4;
3742       }
3743       if (cp2 > dirend) cp2 = dirend;
3744     }
3745     else *(cp1++) = '.';
3746   }
3747   for (; cp2 < dirend; cp2++) {
3748     if (*cp2 == '/') {
3749       if (*(cp2-1) == '/') continue;
3750       if (*(cp1-1) != '.') *(cp1++) = '.';
3751       infront = 0;
3752     }
3753     else if (!infront && *cp2 == '.') {
3754       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3755       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
3756       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3757         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3758         else if (*(cp1-2) == '[') *(cp1-1) = '-';
3759         else {  /* back up over previous directory name */
3760           cp1--;
3761           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3762           if (*(cp1-1) == '[') {
3763             memcpy(cp1,"000000.",7);
3764             cp1 += 7;
3765           }
3766         }
3767         cp2 += 2;
3768         if (cp2 == dirend) break;
3769       }
3770       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3771                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3772         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3773         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3774         if (!*(cp2+3)) {
3775           *(cp1++) = '.';  /* Simulate trailing '/' */
3776           cp2 += 2;  /* for loop will incr this to == dirend */
3777         }
3778         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
3779       }
3780       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
3781     }
3782     else {
3783       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
3784       if (*cp2 == '.')      *(cp1++) = '_';
3785       else                  *(cp1++) =  *cp2;
3786       infront = 1;
3787     }
3788   }
3789   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3790   if (hasdir) *(cp1++) = ']';
3791   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
3792   while (*cp2) *(cp1++) = *(cp2++);
3793   *cp1 = '\0';
3794
3795   return rslt;
3796
3797 }  /* end of do_tovmsspec() */
3798 /*}}}*/
3799 /* External entry points */
3800 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3801 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3802
3803 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3804 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3805   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3806   int vmslen;
3807   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3808
3809   if (path == NULL) return NULL;
3810   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3811   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3812   if (buf) return buf;
3813   else if (ts) {
3814     vmslen = strlen(vmsified);
3815     New(1317,cp,vmslen+1,char);
3816     memcpy(cp,vmsified,vmslen);
3817     cp[vmslen] = '\0';
3818     return cp;
3819   }
3820   else {
3821     strcpy(__tovmspath_retbuf,vmsified);
3822     return __tovmspath_retbuf;
3823   }
3824
3825 }  /* end of do_tovmspath() */
3826 /*}}}*/
3827 /* External entry points */
3828 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3829 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3830
3831
3832 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3833 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3834   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3835   int unixlen;
3836   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3837
3838   if (path == NULL) return NULL;
3839   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3840   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3841   if (buf) return buf;
3842   else if (ts) {
3843     unixlen = strlen(unixified);
3844     New(1317,cp,unixlen+1,char);
3845     memcpy(cp,unixified,unixlen);
3846     cp[unixlen] = '\0';
3847     return cp;
3848   }
3849   else {
3850     strcpy(__tounixpath_retbuf,unixified);
3851     return __tounixpath_retbuf;
3852   }
3853
3854 }  /* end of do_tounixpath() */
3855 /*}}}*/
3856 /* External entry points */
3857 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3858 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3859
3860 /*
3861  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
3862  *
3863  *****************************************************************************
3864  *                                                                           *
3865  *  Copyright (C) 1989-1994 by                                               *
3866  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
3867  *                                                                           *
3868  *  Permission is hereby  granted for the reproduction of this software,     *
3869  *  on condition that this copyright notice is included in the reproduction, *
3870  *  and that such reproduction is not for purposes of profit or material     *
3871  *  gain.                                                                    *
3872  *                                                                           *
3873  *  27-Aug-1994 Modified for inclusion in perl5                              *
3874  *              by Charles Bailey  bailey@newman.upenn.edu                   *
3875  *****************************************************************************
3876  */
3877
3878 /*
3879  * getredirection() is intended to aid in porting C programs
3880  * to VMS (Vax-11 C).  The native VMS environment does not support
3881  * '>' and '<' I/O redirection, or command line wild card expansion,
3882  * or a command line pipe mechanism using the '|' AND background
3883  * command execution '&'.  All of these capabilities are provided to any
3884  * C program which calls this procedure as the first thing in the
3885  * main program.
3886  * The piping mechanism will probably work with almost any 'filter' type
3887  * of program.  With suitable modification, it may useful for other
3888  * portability problems as well.
3889  *
3890  * Author:  Mark Pizzolato      mark@infocomm.com
3891  */
3892 struct list_item
3893     {
3894     struct list_item *next;
3895     char *value;
3896     };
3897
3898 static void add_item(struct list_item **head,
3899                      struct list_item **tail,
3900                      char *value,
3901                      int *count);
3902
3903 static void mp_expand_wild_cards(pTHX_ char *item,
3904                                 struct list_item **head,
3905                                 struct list_item **tail,
3906                                 int *count);
3907
3908 static int background_process(pTHX_ int argc, char **argv);
3909
3910 static void pipe_and_fork(pTHX_ char **cmargv);
3911
3912 /*{{{ void getredirection(int *ac, char ***av)*/
3913 static void
3914 mp_getredirection(pTHX_ int *ac, char ***av)
3915 /*
3916  * Process vms redirection arg's.  Exit if any error is seen.
3917  * If getredirection() processes an argument, it is erased
3918  * from the vector.  getredirection() returns a new argc and argv value.
3919  * In the event that a background command is requested (by a trailing "&"),
3920  * this routine creates a background subprocess, and simply exits the program.
3921  *
3922  * Warning: do not try to simplify the code for vms.  The code
3923  * presupposes that getredirection() is called before any data is
3924  * read from stdin or written to stdout.
3925  *
3926  * Normal usage is as follows:
3927  *
3928  *      main(argc, argv)
3929  *      int             argc;
3930  *      char            *argv[];
3931  *      {
3932  *              getredirection(&argc, &argv);
3933  *      }
3934  */
3935 {
3936     int                 argc = *ac;     /* Argument Count         */
3937     char                **argv = *av;   /* Argument Vector        */
3938     char                *ap;            /* Argument pointer       */
3939     int                 j;              /* argv[] index           */
3940     int                 item_count = 0; /* Count of Items in List */
3941     struct list_item    *list_head = 0; /* First Item in List       */
3942     struct list_item    *list_tail;     /* Last Item in List        */
3943     char                *in = NULL;     /* Input File Name          */
3944     char                *out = NULL;    /* Output File Name         */
3945     char                *outmode = "w"; /* Mode to Open Output File */
3946     char                *err = NULL;    /* Error File Name          */
3947     char                *errmode = "w"; /* Mode to Open Error File  */
3948     int                 cmargc = 0;     /* Piped Command Arg Count  */
3949     char                **cmargv = NULL;/* Piped Command Arg Vector */
3950
3951     /*
3952      * First handle the case where the last thing on the line ends with
3953      * a '&'.  This indicates the desire for the command to be run in a
3954      * subprocess, so we satisfy that desire.
3955      */
3956     ap = argv[argc-1];
3957     if (0 == strcmp("&", ap))
3958        exit(background_process(aTHX_ --argc, argv));
3959     if (*ap && '&' == ap[strlen(ap)-1])
3960         {
3961         ap[strlen(ap)-1] = '\0';
3962        exit(background_process(aTHX_ argc, argv));
3963         }
3964     /*
3965      * Now we handle the general redirection cases that involve '>', '>>',
3966      * '<', and pipes '|'.
3967      */
3968     for (j = 0; j < argc; ++j)
3969         {
3970         if (0 == strcmp("<", argv[j]))
3971             {
3972             if (j+1 >= argc)
3973                 {
3974                 fprintf(stderr,"No input file after < on command line");
3975                 exit(LIB$_WRONUMARG);
3976                 }
3977             in = argv[++j];
3978             continue;
3979             }
3980         if ('<' == *(ap = argv[j]))
3981             {
3982             in = 1 + ap;
3983             continue;
3984             }
3985         if (0 == strcmp(">", ap))
3986             {
3987             if (j+1 >= argc)
3988                 {
3989                 fprintf(stderr,"No output file after > on command line");
3990                 exit(LIB$_WRONUMARG);
3991                 }
3992             out = argv[++j];
3993             continue;
3994             }
3995         if ('>' == *ap)
3996             {
3997             if ('>' == ap[1])
3998                 {
3999                 outmode = "a";
4000                 if ('\0' == ap[2])
4001                     out = argv[++j];
4002                 else
4003                     out = 2 + ap;
4004                 }
4005             else
4006                 out = 1 + ap;
4007             if (j >= argc)
4008                 {
4009                 fprintf(stderr,"No output file after > or >> on command line");
4010                 exit(LIB$_WRONUMARG);
4011                 }
4012             continue;
4013             }
4014         if (('2' == *ap) && ('>' == ap[1]))
4015             {
4016             if ('>' == ap[2])
4017                 {
4018                 errmode = "a";
4019                 if ('\0' == ap[3])
4020                     err = argv[++j];
4021                 else
4022                     err = 3 + ap;
4023                 }
4024             else
4025                 if ('\0' == ap[2])
4026                     err = argv[++j];
4027                 else
4028                     err = 2 + ap;
4029             if (j >= argc)
4030                 {
4031                 fprintf(stderr,"No output file after 2> or 2>> on command line");
4032                 exit(LIB$_WRONUMARG);
4033                 }
4034             continue;
4035             }
4036         if (0 == strcmp("|", argv[j]))
4037             {
4038             if (j+1 >= argc)
4039                 {
4040                 fprintf(stderr,"No command into which to pipe on command line");
4041                 exit(LIB$_WRONUMARG);
4042                 }
4043             cmargc = argc-(j+1);
4044             cmargv = &argv[j+1];
4045             argc = j;
4046             continue;
4047             }
4048         if ('|' == *(ap = argv[j]))
4049             {
4050             ++argv[j];
4051             cmargc = argc-j;
4052             cmargv = &argv[j];
4053             argc = j;
4054             continue;
4055             }
4056         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4057         }
4058     /*
4059      * Allocate and fill in the new argument vector, Some Unix's terminate
4060      * the list with an extra null pointer.
4061      */
4062     New(1302, argv, item_count+1, char *);
4063     *av = argv;
4064     for (j = 0; j < item_count; ++j, list_head = list_head->next)
4065         argv[j] = list_head->value;
4066     *ac = item_count;
4067     if (cmargv != NULL)
4068         {
4069         if (out != NULL)
4070             {
4071             fprintf(stderr,"'|' and '>' may not both be specified on command line");
4072             exit(LIB$_INVARGORD);
4073             }
4074         pipe_and_fork(aTHX_ cmargv);
4075         }
4076
4077     /* Check for input from a pipe (mailbox) */
4078
4079     if (in == NULL && 1 == isapipe(0))
4080         {
4081         char mbxname[L_tmpnam];
4082         long int bufsize;
4083         long int dvi_item = DVI$_DEVBUFSIZ;
4084         $DESCRIPTOR(mbxnam, "");
4085         $DESCRIPTOR(mbxdevnam, "");
4086
4087         /* Input from a pipe, reopen it in binary mode to disable       */
4088         /* carriage control processing.                                 */
4089
4090         fgetname(stdin, mbxname);
4091         mbxnam.dsc$a_pointer = mbxname;
4092         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4093         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4094         mbxdevnam.dsc$a_pointer = mbxname;
4095         mbxdevnam.dsc$w_length = sizeof(mbxname);
4096         dvi_item = DVI$_DEVNAM;
4097         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4098         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4099         set_errno(0);
4100         set_vaxc_errno(1);
4101         freopen(mbxname, "rb", stdin);
4102         if (errno != 0)
4103             {
4104             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4105             exit(vaxc$errno);
4106             }
4107         }
4108     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4109         {
4110         fprintf(stderr,"Can't open input file %s as stdin",in);
4111         exit(vaxc$errno);
4112         }
4113     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4114         {
4115         fprintf(stderr,"Can't open output file %s as stdout",out);
4116         exit(vaxc$errno);
4117         }
4118         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4119
4120     if (err != NULL) {
4121         if (strcmp(err,"&1") == 0) {
4122             dup2(fileno(stdout), fileno(stderr));
4123             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4124         } else {
4125         FILE *tmperr;
4126         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4127             {
4128             fprintf(stderr,"Can't open error file %s as stderr",err);
4129             exit(vaxc$errno);
4130             }
4131             fclose(tmperr);
4132            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4133                 {
4134                 exit(vaxc$errno);
4135                 }
4136             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4137         }
4138         }
4139 #ifdef ARGPROC_DEBUG
4140     PerlIO_printf(Perl_debug_log, "Arglist:\n");
4141     for (j = 0; j < *ac;  ++j)
4142         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4143 #endif
4144    /* Clear errors we may have hit expanding wildcards, so they don't
4145       show up in Perl's $! later */
4146    set_errno(0); set_vaxc_errno(1);
4147 }  /* end of getredirection() */
4148 /*}}}*/
4149
4150 static void add_item(struct list_item **head,
4151                      struct list_item **tail,
4152                      char *value,
4153                      int *count)
4154 {
4155     if (*head == 0)
4156         {
4157         New(1303,*head,1,struct list_item);
4158         *tail = *head;
4159         }
4160     else {
4161         New(1304,(*tail)->next,1,struct list_item);
4162         *tail = (*tail)->next;
4163         }
4164     (*tail)->value = value;
4165     ++(*count);
4166 }
4167
4168 static void mp_expand_wild_cards(pTHX_ char *item,
4169                               struct list_item **head,
4170                               struct list_item **tail,
4171                               int *count)
4172 {
4173 int expcount = 0;
4174 unsigned long int context = 0;
4175 int isunix = 0;
4176 char *had_version;
4177 char *had_device;
4178 int had_directory;
4179 char *devdir,*cp;
4180 char vmsspec[NAM$C_MAXRSS+1];
4181 $DESCRIPTOR(filespec, "");
4182 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4183 $DESCRIPTOR(resultspec, "");
4184 unsigned long int zero = 0, sts;
4185
4186     for (cp = item; *cp; cp++) {
4187         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4188         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4189     }
4190     if (!*cp || isspace(*cp))
4191         {
4192         add_item(head, tail, item, count);
4193         return;
4194         }
4195     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4196     resultspec.dsc$b_class = DSC$K_CLASS_D;
4197     resultspec.dsc$a_pointer = NULL;
4198     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4199       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4200     if (!isunix || !filespec.dsc$a_pointer)
4201       filespec.dsc$a_pointer = item;
4202     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4203     /*
4204      * Only return version specs, if the caller specified a version
4205      */
4206     had_version = strchr(item, ';');
4207     /*
4208      * Only return device and directory specs, if the caller specifed either.
4209      */
4210     had_device = strchr(item, ':');
4211     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4212
4213     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4214                                   &defaultspec, 0, 0, &zero))))
4215         {
4216         char *string;
4217         char *c;
4218
4219         New(1305,string,resultspec.dsc$w_length+1,char);
4220         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4221         string[resultspec.dsc$w_length] = '\0';
4222         if (NULL == had_version)
4223             *((char *)strrchr(string, ';')) = '\0';
4224         if ((!had_directory) && (had_device == NULL))
4225             {
4226             if (NULL == (devdir = strrchr(string, ']')))
4227                 devdir = strrchr(string, '>');
4228             strcpy(string, devdir + 1);
4229             }
4230         /*
4231          * Be consistent with what the C RTL has already done to the rest of
4232          * the argv items and lowercase all of these names.
4233          */
4234         for (c = string; *c; ++c)
4235             if (isupper(*c))
4236                 *c = tolower(*c);
4237         if (isunix) trim_unixpath(string,item,1);
4238         add_item(head, tail, string, count);
4239         ++expcount;
4240         }
4241     if (sts != RMS$_NMF)
4242         {
4243         set_vaxc_errno(sts);
4244         switch (sts)
4245             {
4246             case RMS$_FNF: case RMS$_DNF:
4247                 set_errno(ENOENT); break;
4248             case RMS$_DIR:
4249                 set_errno(ENOTDIR); break;
4250             case RMS$_DEV:
4251                 set_errno(ENODEV); break;
4252             case RMS$_FNM: case RMS$_SYN:
4253                 set_errno(EINVAL); break;
4254             case RMS$_PRV:
4255                 set_errno(EACCES); break;
4256             default:
4257                 _ckvmssts_noperl(sts);
4258             }
4259         }
4260     if (expcount == 0)
4261         add_item(head, tail, item, count);
4262     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4263     _ckvmssts_noperl(lib$find_file_end(&context));
4264 }
4265
4266 static int child_st[2];/* Event Flag set when child process completes   */
4267
4268 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
4269
4270 static unsigned long int exit_handler(int *status)
4271 {
4272 short iosb[4];
4273
4274     if (0 == child_st[0])
4275         {
4276 #ifdef ARGPROC_DEBUG
4277         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4278 #endif
4279         fflush(stdout);     /* Have to flush pipe for binary data to    */
4280                             /* terminate properly -- <tp@mccall.com>    */
4281         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4282         sys$dassgn(child_chan);
4283         fclose(stdout);
4284         sys$synch(0, child_st);
4285         }
4286     return(1);
4287 }
4288
4289 static void sig_child(int chan)
4290 {
4291 #ifdef ARGPROC_DEBUG
4292     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4293 #endif
4294     if (child_st[0] == 0)
4295         child_st[0] = 1;
4296 }
4297
4298 static struct exit_control_block exit_block =
4299     {
4300     0,
4301     exit_handler,
4302     1,
4303     &exit_block.exit_status,
4304     0
4305     };
4306
4307 static void
4308 pipe_and_fork(pTHX_ char **cmargv)
4309 {
4310     PerlIO *fp;
4311     struct dsc$descriptor_s *vmscmd;
4312     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4313     int sts, j, l, ismcr, quote, tquote = 0;
4314
4315     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
4316     vms_execfree(vmscmd);
4317
4318     j = l = 0;
4319     p = subcmd;
4320     q = cmargv[0];
4321     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
4322               && toupper(*(q+2)) == 'R' && !*(q+3);
4323
4324     while (q && l < MAX_DCL_LINE_LENGTH) {
4325         if (!*q) {
4326             if (j > 0 && quote) {
4327                 *p++ = '"';
4328                 l++;
4329             }
4330             q = cmargv[++j];
4331             if (q) {
4332                 if (ismcr && j > 1) quote = 1;
4333                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
4334                 *p++ = ' ';
4335                 l++;
4336                 if (quote || tquote) {
4337                     *p++ = '"';
4338                     l++;
4339                 }
4340         }
4341         } else {
4342             if ((quote||tquote) && *q == '"') {
4343                 *p++ = '"';
4344                 l++;
4345         }
4346             *p++ = *q++;
4347             l++;
4348         }
4349     }
4350     *p = '\0';
4351
4352     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4353     if (fp == Nullfp) {
4354         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4355         }
4356 }
4357
4358 static int background_process(pTHX_ int argc, char **argv)
4359 {
4360 char command[2048] = "$";
4361 $DESCRIPTOR(value, "");
4362 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4363 static $DESCRIPTOR(null, "NLA0:");
4364 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4365 char pidstring[80];
4366 $DESCRIPTOR(pidstr, "");
4367 int pid;
4368 unsigned long int flags = 17, one = 1, retsts;
4369
4370     strcat(command, argv[0]);
4371     while (--argc)
4372         {
4373         strcat(command, " \"");
4374         strcat(command, *(++argv));
4375         strcat(command, "\"");
4376         }
4377     value.dsc$a_pointer = command;
4378     value.dsc$w_length = strlen(value.dsc$a_pointer);
4379     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4380     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4381     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4382         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4383     }
4384     else {
4385         _ckvmssts_noperl(retsts);
4386     }
4387 #ifdef ARGPROC_DEBUG
4388     PerlIO_printf(Perl_debug_log, "%s\n", command);
4389 #endif
4390     sprintf(pidstring, "%08X", pid);
4391     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4392     pidstr.dsc$a_pointer = pidstring;
4393     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4394     lib$set_symbol(&pidsymbol, &pidstr);
4395     return(SS$_NORMAL);
4396 }
4397 /*}}}*/
4398 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4399
4400
4401 /* OS-specific initialization at image activation (not thread startup) */
4402 /* Older VAXC header files lack these constants */
4403 #ifndef JPI$_RIGHTS_SIZE
4404 #  define JPI$_RIGHTS_SIZE 817
4405 #endif
4406 #ifndef KGB$M_SUBSYSTEM
4407 #  define KGB$M_SUBSYSTEM 0x8
4408 #endif
4409
4410 /*{{{void vms_image_init(int *, char ***)*/
4411 void
4412 vms_image_init(int *argcp, char ***argvp)
4413 {
4414   char eqv[LNM$C_NAMLENGTH+1] = "";
4415   unsigned int len, tabct = 8, tabidx = 0;
4416   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4417   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4418   unsigned short int dummy, rlen;
4419   struct dsc$descriptor_s **tabvec;
4420 #if defined(PERL_IMPLICIT_CONTEXT)
4421   pTHX = NULL;
4422 #endif
4423   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
4424                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
4425                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4426                                  {          0,                0,    0,      0} };
4427
4428 #ifdef KILL_BY_SIGPRC
4429     (void) Perl_csighandler_init();
4430 #endif
4431
4432   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4433   _ckvmssts_noperl(iosb[0]);
4434   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4435     if (iprv[i]) {           /* Running image installed with privs? */
4436       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
4437       will_taint = TRUE;
4438       break;
4439     }
4440   }
4441   /* Rights identifiers might trigger tainting as well. */
4442   if (!will_taint && (rlen || rsz)) {
4443     while (rlen < rsz) {
4444       /* We didn't get all the identifiers on the first pass.  Allocate a
4445        * buffer much larger than $GETJPI wants (rsz is size in bytes that
4446        * were needed to hold all identifiers at time of last call; we'll
4447        * allocate that many unsigned long ints), and go back and get 'em.
4448        * If it gave us less than it wanted to despite ample buffer space,
4449        * something's broken.  Is your system missing a system identifier?
4450        */
4451       if (rsz <= jpilist[1].buflen) {
4452          /* Perl_croak accvios when used this early in startup. */
4453          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4454                          rsz, (unsigned long) jpilist[1].buflen,
4455                          "Check your rights database for corruption.\n");
4456          exit(SS$_ABORT);
4457       }
4458       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4459       jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4460       jpilist[1].buflen = rsz * sizeof(unsigned long int);
4461       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4462       _ckvmssts_noperl(iosb[0]);
4463     }
4464     mask = jpilist[1].bufadr;
4465     /* Check attribute flags for each identifier (2nd longword); protected
4466      * subsystem identifiers trigger tainting.
4467      */
4468     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4469       if (mask[i] & KGB$M_SUBSYSTEM) {
4470         will_taint = TRUE;
4471         break;
4472       }
4473     }
4474     if (mask != rlst) Safefree(mask);
4475   }
4476   /* We need to use this hack to tell Perl it should run with tainting,
4477    * since its tainting flag may be part of the PL_curinterp struct, which
4478    * hasn't been allocated when vms_image_init() is called.
4479    */
4480   if (will_taint) {
4481     char ***newap;
4482     New(1320,newap,*argcp+2,char **);
4483     newap[0] = argvp[0];
4484     *newap[1] = "-T";
4485     Copy(argvp[1],newap[2],*argcp-1,char **);
4486     /* We orphan the old argv, since we don't know where it's come from,
4487      * so we don't know how to free it.
4488      */
4489     *argcp++; argvp = newap;
4490   }
4491   else {  /* Did user explicitly request tainting? */
4492     int i;
4493     char *cp, **av = *argvp;
4494     for (i = 1; i < *argcp; i++) {
4495       if (*av[i] != '-') break;
4496       for (cp = av[i]+1; *cp; cp++) {
4497         if (*cp == 'T') { will_taint = 1; break; }
4498         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4499                   strchr("DFIiMmx",*cp)) break;
4500       }
4501       if (will_taint) break;
4502     }
4503   }
4504
4505   for (tabidx = 0;
4506        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4507        tabidx++) {
4508     if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4509     else if (tabidx >= tabct) {
4510       tabct += 8;
4511       Renew(tabvec,tabct,struct dsc$descriptor_s *);
4512     }
4513     New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4514     tabvec[tabidx]->dsc$w_length  = 0;
4515     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
4516     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
4517     tabvec[tabidx]->dsc$a_pointer = NULL;
4518     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4519   }
4520   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4521
4522   getredirection(argcp,argvp);
4523 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4524   {
4525 # include <reentrancy.h>
4526   (void) decc$set_reentrancy(C$C_MULTITHREAD);
4527   }
4528 #endif
4529   return;
4530 }
4531 /*}}}*/
4532
4533
4534 /* trim_unixpath()
4535  * Trim Unix-style prefix off filespec, so it looks like what a shell
4536  * glob expansion would return (i.e. from specified prefix on, not
4537  * full path).  Note that returned filespec is Unix-style, regardless
4538  * of whether input filespec was VMS-style or Unix-style.
4539  *
4540  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4541  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
4542  * vector of options; at present, only bit 0 is used, and if set tells
4543  * trim unixpath to try the current default directory as a prefix when
4544  * presented with a possibly ambiguous ... wildcard.
4545  *
4546  * Returns !=0 on success, with trimmed filespec replacing contents of
4547  * fspec, and 0 on failure, with contents of fpsec unchanged.
4548  */
4549 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4550 int
4551 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4552 {
4553   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4554        *template, *base, *end, *cp1, *cp2;
4555   register int tmplen, reslen = 0, dirs = 0;
4556
4557   if (!wildspec || !fspec) return 0;
4558   if (strpbrk(wildspec,"]>:") != NULL) {
4559     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4560     else template = unixwild;
4561   }
4562   else template = wildspec;
4563   if (strpbrk(fspec,"]>:") != NULL) {
4564     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4565     else base = unixified;
4566     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4567      * check to see that final result fits into (isn't longer than) fspec */
4568     reslen = strlen(fspec);
4569   }
4570   else base = fspec;
4571
4572   /* No prefix or absolute path on wildcard, so nothing to remove */
4573   if (!*template || *template == '/') {
4574     if (base == fspec) return 1;
4575     tmplen = strlen(unixified);
4576     if (tmplen > reslen) return 0;  /* not enough space */
4577     /* Copy unixified resultant, including trailing NUL */
4578     memmove(fspec,unixified,tmplen+1);
4579     return 1;
4580   }
4581
4582   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
4583   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4584     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4585     for (cp1 = end ;cp1 >= base; cp1--)
4586       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4587         { cp1++; break; }
4588     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4589     return 1;
4590   }
4591   else {
4592     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4593     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4594     int ells = 1, totells, segdirs, match;
4595     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4596                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4597
4598     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4599     totells = ells;
4600     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4601     if (ellipsis == template && opts & 1) {
4602       /* Template begins with an ellipsis.  Since we can't tell how many
4603        * directory names at the front of the resultant to keep for an
4604        * arbitrary starting point, we arbitrarily choose the current
4605        * default directory as a starting point.  If it's there as a prefix,
4606        * clip it off.  If not, fall through and act as if the leading
4607        * ellipsis weren't there (i.e. return shortest possible path that
4608        * could match template).
4609        */
4610       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4611       for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4612         if (_tolower(*cp1) != _tolower(*cp2)) break;
4613       segdirs = dirs - totells;  /* Min # of dirs we must have left */
4614       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4615       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4616         memcpy(fspec,cp2+1,end - cp2);
4617         return 1;
4618       }
4619     }
4620     /* First off, back up over constant elements at end of path */
4621     if (dirs) {
4622       for (front = end ; front >= base; front--)
4623          if (*front == '/' && !dirs--) { front++; break; }
4624     }
4625     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4626          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
4627     if (cp1 != '\0') return 0;  /* Path too long. */
4628     lcend = cp2;
4629     *cp2 = '\0';  /* Pick up with memcpy later */
4630     lcfront = lcres + (front - base);
4631     /* Now skip over each ellipsis and try to match the path in front of it. */
4632     while (ells--) {
4633       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4634         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
4635             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
4636       if (cp1 < template) break; /* template started with an ellipsis */
4637       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4638         ellipsis = cp1; continue;
4639       }
4640       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4641       nextell = cp1;
4642       for (segdirs = 0, cp2 = tpl;
4643            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4644            cp1++, cp2++) {
4645          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4646          else *cp2 = _tolower(*cp1);  /* else lowercase for match */
4647          if (*cp2 == '/') segdirs++;
4648       }
4649       if (cp1 != ellipsis - 1) return 0; /* Path too long */
4650       /* Back up at least as many dirs as in template before matching */
4651       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4652         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4653       for (match = 0; cp1 > lcres;) {
4654         resdsc.dsc$a_pointer = cp1;
4655         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4656           match++;
4657           if (match == 1) lcfront = cp1;
4658         }
4659         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4660       }
4661       if (!match) return 0;  /* Can't find prefix ??? */
4662       if (match > 1 && opts & 1) {
4663         /* This ... wildcard could cover more than one set of dirs (i.e.
4664          * a set of similar dir names is repeated).  If the template
4665          * contains more than 1 ..., upstream elements could resolve the
4666          * ambiguity, but it's not worth a full backtracking setup here.
4667          * As a quick heuristic, clip off the current default directory
4668          * if it's present to find the trimmed spec, else use the
4669          * shortest string that this ... could cover.
4670          */
4671         char def[NAM$C_MAXRSS+1], *st;
4672
4673         if (getcwd(def, sizeof def,0) == NULL) return 0;
4674         for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4675           if (_tolower(*cp1) != _tolower(*cp2)) break;
4676         segdirs = dirs - totells;  /* Min # of dirs we must have left */
4677         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4678         if (*cp1 == '\0' && *cp2 == '/') {
4679           memcpy(fspec,cp2+1,end - cp2);
4680           return 1;
4681         }
4682         /* Nope -- stick with lcfront from above and keep going. */
4683       }
4684     }
4685     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4686     return 1;
4687     ellipsis = nextell;
4688   }
4689
4690 }  /* end of trim_unixpath() */
4691 /*}}}*/
4692
4693
4694 /*
4695  *  VMS readdir() routines.
4696  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4697  *
4698  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
4699  *  Minor modifications to original routines.
4700  */
4701
4702     /* Number of elements in vms_versions array */
4703 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
4704
4705 /*
4706  *  Open a directory, return a handle for later use.
4707  */
4708 /*{{{ DIR *opendir(char*name) */
4709 DIR *
4710 Perl_opendir(pTHX_ char *name)
4711 {
4712     DIR *dd;
4713     char dir[NAM$C_MAXRSS+1];
4714     Stat_t sb;
4715
4716     if (do_tovmspath(name,dir,0) == NULL) {
4717       return NULL;
4718     }
4719     /* Check access before stat; otherwise stat does not
4720      * accurately report whether it's a directory.
4721      */
4722     if (!cando_by_name(S_IRUSR,0,dir)) {
4723       set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4724       return NULL;
4725     }
4726     if (flex_stat(dir,&sb) == -1) return NULL;
4727     if (!S_ISDIR(sb.st_mode)) {
4728       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
4729       return NULL;
4730     }
4731     /* Get memory for the handle, and the pattern. */
4732     New(1306,dd,1,DIR);
4733     New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4734
4735     /* Fill in the fields; mainly playing with the descriptor. */
4736     (void)sprintf(dd->pattern, "%s*.*",dir);
4737     dd->context = 0;
4738     dd->count = 0;
4739     dd->vms_wantversions = 0;
4740     dd->pat.dsc$a_pointer = dd->pattern;
4741     dd->pat.dsc$w_length = strlen(dd->pattern);
4742     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4743     dd->pat.dsc$b_class = DSC$K_CLASS_S;
4744
4745     return dd;
4746 }  /* end of opendir() */
4747 /*}}}*/
4748
4749 /*
4750  *  Set the flag to indicate we want versions or not.
4751  */
4752 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4753 void
4754 vmsreaddirversions(DIR *dd, int flag)
4755 {
4756     dd->vms_wantversions = flag;
4757 }
4758 /*}}}*/
4759
4760 /*
4761  *  Free up an opened directory.
4762  */
4763 /*{{{ void closedir(DIR *dd)*/
4764 void
4765 closedir(DIR *dd)
4766 {
4767     (void)lib$find_file_end(&dd->context);
4768     Safefree(dd->pattern);
4769     Safefree((char *)dd);
4770 }
4771 /*}}}*/
4772
4773 /*
4774  *  Collect all the version numbers for the current file.
4775  */
4776 static void
4777 collectversions(pTHX_ DIR *dd)
4778 {
4779     struct dsc$descriptor_s     pat;
4780     struct dsc$descriptor_s     res;
4781     struct dirent *e;
4782     char *p, *text, buff[sizeof dd->entry.d_name];
4783     int i;
4784     unsigned long context, tmpsts;
4785
4786     /* Convenient shorthand. */
4787     e = &dd->entry;
4788
4789     /* Add the version wildcard, ignoring the "*.*" put on before */
4790     i = strlen(dd->pattern);
4791     New(1308,text,i + e->d_namlen + 3,char);
4792     (void)strcpy(text, dd->pattern);
4793     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4794
4795     /* Set up the pattern descriptor. */
4796     pat.dsc$a_pointer = text;
4797     pat.dsc$w_length = i + e->d_namlen - 1;
4798     pat.dsc$b_dtype = DSC$K_DTYPE_T;
4799     pat.dsc$b_class = DSC$K_CLASS_S;
4800
4801     /* Set up result descriptor. */
4802     res.dsc$a_pointer = buff;
4803     res.dsc$w_length = sizeof buff - 2;
4804     res.dsc$b_dtype = DSC$K_DTYPE_T;
4805     res.dsc$b_class = DSC$K_CLASS_S;
4806
4807     /* Read files, collecting versions. */
4808     for (context = 0, e->vms_verscount = 0;
4809          e->vms_verscount < VERSIZE(e);
4810          e->vms_verscount++) {
4811         tmpsts = lib$find_file(&pat, &res, &context);
4812         if (tmpsts == RMS$_NMF || context == 0) break;
4813         _ckvmssts(tmpsts);
4814         buff[sizeof buff - 1] = '\0';
4815         if ((p = strchr(buff, ';')))
4816             e->vms_versions[e->vms_verscount] = atoi(p + 1);
4817         else
4818             e->vms_versions[e->vms_verscount] = -1;
4819     }
4820
4821     _ckvmssts(lib$find_file_end(&context));
4822     Safefree(text);
4823
4824 }  /* end of collectversions() */
4825
4826 /*
4827  *  Read the next entry from the directory.
4828  */
4829 /*{{{ struct dirent *readdir(DIR *dd)*/
4830 struct dirent *
4831 Perl_readdir(pTHX_ DIR *dd)
4832 {
4833     struct dsc$descriptor_s     res;
4834     char *p, buff[sizeof dd->entry.d_name];
4835     unsigned long int tmpsts;
4836
4837     /* Set up result descriptor, and get next file. */
4838     res.dsc$a_pointer = buff;
4839     res.dsc$w_length = sizeof buff - 2;
4840     res.dsc$b_dtype = DSC$K_DTYPE_T;
4841     res.dsc$b_class = DSC$K_CLASS_S;
4842     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4843     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
4844     if (!(tmpsts & 1)) {
4845       set_vaxc_errno(tmpsts);
4846       switch (tmpsts) {
4847         case RMS$_PRV:
4848           set_errno(EACCES); break;
4849         case RMS$_DEV:
4850           set_errno(ENODEV); break;
4851         case RMS$_DIR:
4852           set_errno(ENOTDIR); break;
4853         case RMS$_FNF: case RMS$_DNF:
4854           set_errno(ENOENT); break;
4855         default:
4856           set_errno(EVMSERR);
4857       }
4858       return NULL;
4859     }
4860     dd->count++;
4861     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4862     buff[sizeof buff - 1] = '\0';
4863     for (p = buff; *p; p++) *p = _tolower(*p);
4864     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
4865     *p = '\0';
4866
4867     /* Skip any directory component and just copy the name. */
4868     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4869     else (void)strcpy(dd->entry.d_name, buff);
4870
4871     /* Clobber the version. */
4872     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4873
4874     dd->entry.d_namlen = strlen(dd->entry.d_name);
4875     dd->entry.vms_verscount = 0;
4876     if (dd->vms_wantversions) collectversions(aTHX_ dd);
4877     return &dd->entry;
4878
4879 }  /* end of readdir() */
4880 /*}}}*/
4881
4882 /*
4883  *  Return something that can be used in a seekdir later.
4884  */
4885 /*{{{ long telldir(DIR *dd)*/
4886 long
4887 telldir(DIR *dd)
4888 {
4889     return dd->count;
4890 }
4891 /*}}}*/
4892
4893 /*
4894  *  Return to a spot where we used to be.  Brute force.
4895  */
4896 /*{{{ void seekdir(DIR *dd,long count)*/
4897 void
4898 Perl_seekdir(pTHX_ DIR *dd, long count)
4899 {
4900     int vms_wantversions;
4901
4902     /* If we haven't done anything yet... */
4903     if (dd->count == 0)
4904         return;
4905
4906     /* Remember some state, and clear it. */
4907     vms_wantversions = dd->vms_wantversions;
4908     dd->vms_wantversions = 0;
4909     _ckvmssts(lib$find_file_end(&dd->context));
4910     dd->context = 0;
4911
4912     /* The increment is in readdir(). */
4913     for (dd->count = 0; dd->count < count; )
4914         (void)readdir(dd);
4915
4916     dd->vms_wantversions = vms_wantversions;
4917
4918 }  /* end of seekdir() */
4919 /*}}}*/
4920
4921 /* VMS subprocess management
4922  *
4923  * my_vfork() - just a vfork(), after setting a flag to record that
4924  * the current script is trying a Unix-style fork/exec.
4925  *
4926  * vms_do_aexec() and vms_do_exec() are called in response to the
4927  * perl 'exec' function.  If this follows a vfork call, then they
4928  * call out the the regular perl routines in doio.c which do an
4929  * execvp (for those who really want to try this under VMS).
4930  * Otherwise, they do exactly what the perl docs say exec should
4931  * do - terminate the current script and invoke a new command
4932  * (See below for notes on command syntax.)
4933  *
4934  * do_aspawn() and do_spawn() implement the VMS side of the perl
4935  * 'system' function.
4936  *
4937  * Note on command arguments to perl 'exec' and 'system': When handled
4938  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4939  * are concatenated to form a DCL command string.  If the first arg
4940  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4941  * the the command string is handed off to DCL directly.  Otherwise,
4942  * the first token of the command is taken as the filespec of an image
4943  * to run.  The filespec is expanded using a default type of '.EXE' and
4944  * the process defaults for device, directory, etc., and if found, the resultant
4945  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4946  * the command string as parameters.  This is perhaps a bit complicated,
4947  * but I hope it will form a happy medium between what VMS folks expect
4948  * from lib$spawn and what Unix folks expect from exec.
4949  */
4950
4951 static int vfork_called;
4952
4953 /*{{{int my_vfork()*/
4954 int
4955 my_vfork()
4956 {
4957   vfork_called++;
4958   return vfork();
4959 }
4960 /*}}}*/
4961
4962
4963 static void
4964 vms_execfree(struct dsc$descriptor_s *vmscmd)
4965 {
4966   if (vmscmd) {
4967       if (vmscmd->dsc$a_pointer) {
4968           Safefree(vmscmd->dsc$a_pointer);
4969       }
4970       Safefree(vmscmd);
4971   }
4972 }
4973
4974 static char *
4975 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4976 {
4977   char *junk, *tmps = Nullch;
4978   register size_t cmdlen = 0;
4979   size_t rlen;
4980   register SV **idx;
4981   STRLEN n_a;
4982
4983   idx = mark;
4984   if (really) {
4985     tmps = SvPV(really,rlen);
4986     if (*tmps) {
4987       cmdlen += rlen + 1;
4988       idx++;
4989     }
4990   }
4991
4992   for (idx++; idx <= sp; idx++) {
4993     if (*idx) {
4994       junk = SvPVx(*idx,rlen);
4995       cmdlen += rlen ? rlen + 1 : 0;
4996     }
4997   }
4998   New(401,PL_Cmd,cmdlen+1,char);
4999
5000   if (tmps && *tmps) {
5001     strcpy(PL_Cmd,tmps);
5002     mark++;
5003   }
5004   else *PL_Cmd = '\0';
5005   while (++mark <= sp) {
5006     if (*mark) {
5007       char *s = SvPVx(*mark,n_a);
5008       if (!*s) continue;
5009       if (*PL_Cmd) strcat(PL_Cmd," ");
5010       strcat(PL_Cmd,s);
5011     }
5012   }
5013   return PL_Cmd;
5014
5015 }  /* end of setup_argstr() */
5016
5017
5018 static unsigned long int
5019 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5020                    struct dsc$descriptor_s **pvmscmd)
5021 {
5022   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5023   $DESCRIPTOR(defdsc,".EXE");
5024   $DESCRIPTOR(defdsc2,".");
5025   $DESCRIPTOR(resdsc,resspec);
5026   struct dsc$descriptor_s *vmscmd;
5027   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5028   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5029   register char *s, *rest, *cp, *wordbreak;
5030   register int isdcl;
5031
5032   New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5033   vmscmd->dsc$a_pointer = NULL;
5034   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
5035   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
5036   vmscmd->dsc$w_length = 0;
5037   if (pvmscmd) *pvmscmd = vmscmd;
5038
5039   if (suggest_quote) *suggest_quote = 0;
5040
5041   if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5042     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
5043   s = cmd;
5044   while (*s && isspace(*s)) s++;
5045
5046   if (*s == '@' || *s == '$') {
5047     vmsspec[0] = *s;  rest = s + 1;
5048     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5049   }
5050   else { cp = vmsspec; rest = s; }
5051   if (*rest == '.' || *rest == '/') {
5052     char *cp2;
5053     for (cp2 = resspec;
5054          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5055          rest++, cp2++) *cp2 = *rest;
5056     *cp2 = '\0';
5057     if (do_tovmsspec(resspec,cp,0)) {
5058       s = vmsspec;
5059       if (*rest) {
5060         for (cp2 = vmsspec + strlen(vmsspec);
5061              *rest && cp2 - vmsspec < sizeof vmsspec;
5062              rest++, cp2++) *cp2 = *rest;
5063         *cp2 = '\0';
5064       }
5065     }
5066   }
5067   /* Intuit whether verb (first word of cmd) is a DCL command:
5068    *   - if first nonspace char is '@', it's a DCL indirection
5069    * otherwise
5070    *   - if verb contains a filespec separator, it's not a DCL command
5071    *   - if it doesn't, caller tells us whether to default to a DCL
5072    *     command, or to a local image unless told it's DCL (by leading '$')
5073    */
5074   if (*s == '@') {
5075       isdcl = 1;
5076       if (suggest_quote) *suggest_quote = 1;
5077   } else {
5078     register char *filespec = strpbrk(s,":<[.;");
5079     rest = wordbreak = strpbrk(s," \"\t/");
5080     if (!wordbreak) wordbreak = s + strlen(s);
5081     if (*s == '$') check_img = 0;
5082     if (filespec && (filespec < wordbreak)) isdcl = 0;
5083     else isdcl = !check_img;
5084   }
5085
5086   if (!isdcl) {
5087     imgdsc.dsc$a_pointer = s;
5088     imgdsc.dsc$w_length = wordbreak - s;
5089     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5090     if (!(retsts&1)) {
5091         _ckvmssts(lib$find_file_end(&cxt));
5092         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5093     if (!(retsts & 1) && *s == '$') {
5094           _ckvmssts(lib$find_file_end(&cxt));
5095       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5096       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5097           if (!(retsts&1)) {
5098       _ckvmssts(lib$find_file_end(&cxt));
5099             retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5100           }
5101     }
5102     }
5103     _ckvmssts(lib$find_file_end(&cxt));
5104
5105     if (retsts & 1) {
5106       FILE *fp;
5107       s = resspec;
5108       while (*s && !isspace(*s)) s++;
5109       *s = '\0';
5110
5111       /* check that it's really not DCL with no file extension */
5112       fp = fopen(resspec,"r","ctx=bin,shr=get");
5113       if (fp) {
5114         char b[4] = {0,0,0,0};
5115         read(fileno(fp),b,4);
5116         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5117         fclose(fp);
5118       }
5119       if (check_img && isdcl) return RMS$_FNF;
5120
5121       if (cando_by_name(S_IXUSR,0,resspec)) {
5122         New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5123         if (!isdcl) {
5124             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5125             if (suggest_quote) *suggest_quote = 1;
5126         } else {
5127             strcpy(vmscmd->dsc$a_pointer,"@");
5128             if (suggest_quote) *suggest_quote = 1;
5129         }
5130         strcat(vmscmd->dsc$a_pointer,resspec);
5131         if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5132         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5133         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5134       }
5135       else retsts = RMS$_PRV;
5136     }
5137   }
5138   /* It's either a DCL command or we couldn't find a suitable image */
5139   vmscmd->dsc$w_length = strlen(cmd);
5140 /*  if (cmd == PL_Cmd) {
5141       vmscmd->dsc$a_pointer = PL_Cmd;
5142       if (suggest_quote) *suggest_quote = 1;
5143   }
5144   else  */
5145       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5146
5147   /* check if it's a symbol (for quoting purposes) */
5148   if (suggest_quote && !*suggest_quote) {
5149     int iss;
5150     char equiv[LNM$C_NAMLENGTH];
5151     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5152     eqvdsc.dsc$a_pointer = equiv;
5153
5154     iss = lib$get_symbol(vmscmd,&eqvdsc);
5155     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5156   }
5157   if (!(retsts & 1)) {
5158     /* just hand off status values likely to be due to user error */
5159     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5160         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5161        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5162     else { _ckvmssts(retsts); }
5163   }
5164
5165   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5166
5167 }  /* end of setup_cmddsc() */
5168
5169
5170 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5171 bool
5172 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5173 {
5174   if (sp > mark) {
5175     if (vfork_called) {           /* this follows a vfork - act Unixish */
5176       vfork_called--;
5177       if (vfork_called < 0) {
5178         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5179         vfork_called = 0;
5180       }
5181       else return do_aexec(really,mark,sp);
5182     }
5183                                            /* no vfork - act VMSish */
5184     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5185
5186   }
5187
5188   return FALSE;
5189 }  /* end of vms_do_aexec() */
5190 /*}}}*/
5191
5192 /* {{{bool vms_do_exec(char *cmd) */
5193 bool
5194 Perl_vms_do_exec(pTHX_ char *cmd)
5195 {
5196   struct dsc$descriptor_s *vmscmd;
5197
5198   if (vfork_called) {             /* this follows a vfork - act Unixish */
5199     vfork_called--;
5200     if (vfork_called < 0) {
5201       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5202       vfork_called = 0;
5203     }
5204     else return do_exec(cmd);
5205   }
5206
5207   {                               /* no vfork - act VMSish */
5208     unsigned long int retsts;
5209
5210     TAINT_ENV();
5211     TAINT_PROPER("exec");
5212     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5213       retsts = lib$do_command(vmscmd);
5214
5215     switch (retsts) {
5216       case RMS$_FNF: case RMS$_DNF:
5217         set_errno(ENOENT); break;
5218       case RMS$_DIR:
5219         set_errno(ENOTDIR); break;
5220       case RMS$_DEV:
5221         set_errno(ENODEV); break;
5222       case RMS$_PRV:
5223         set_errno(EACCES); break;
5224       case RMS$_SYN:
5225         set_errno(EINVAL); break;
5226       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5227         set_errno(E2BIG); break;
5228       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5229         _ckvmssts(retsts); /* fall through */
5230       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5231         set_errno(EVMSERR);
5232     }
5233     set_vaxc_errno(retsts);
5234     if (ckWARN(WARN_EXEC)) {
5235       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5236              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5237     }
5238     vms_execfree(vmscmd);
5239   }
5240
5241   return FALSE;
5242
5243 }  /* end of vms_do_exec() */
5244 /*}}}*/
5245
5246 unsigned long int Perl_do_spawn(pTHX_ char *);
5247
5248 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5249 unsigned long int
5250 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5251 {
5252   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5253
5254   return SS$_ABORT;
5255 }  /* end of do_aspawn() */
5256 /*}}}*/
5257
5258 /* {{{unsigned long int do_spawn(char *cmd) */
5259 unsigned long int
5260 Perl_do_spawn(pTHX_ char *cmd)
5261 {
5262   unsigned long int sts, substs;
5263
5264   TAINT_ENV();
5265   TAINT_PROPER("spawn");
5266   if (!cmd || !*cmd) {
5267     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5268     if (!(sts & 1)) {
5269       switch (sts) {
5270         case RMS$_FNF:  case RMS$_DNF:
5271           set_errno(ENOENT); break;
5272         case RMS$_DIR:
5273           set_errno(ENOTDIR); break;
5274         case RMS$_DEV:
5275           set_errno(ENODEV); break;
5276         case RMS$_PRV:
5277           set_errno(EACCES); break;
5278         case RMS$_SYN:
5279           set_errno(EINVAL); break;
5280         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5281           set_errno(E2BIG); break;
5282         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5283           _ckvmssts(sts); /* fall through */
5284         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5285           set_errno(EVMSERR);
5286       }
5287       set_vaxc_errno(sts);
5288       if (ckWARN(WARN_EXEC)) {
5289         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5290                     Strerror(errno));
5291       }
5292     }
5293     sts = substs;
5294   }
5295   else {
5296     (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5297   }
5298   return sts;
5299 }  /* end of do_spawn() */
5300 /*}}}*/
5301
5302
5303 static unsigned int *sockflags, sockflagsize;
5304
5305 /*
5306  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5307  * routines found in some versions of the CRTL can't deal with sockets.
5308  * We don't shim the other file open routines since a socket isn't
5309  * likely to be opened by a name.
5310  */
5311 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5312 FILE *my_fdopen(int fd, const char *mode)
5313 {
5314   FILE *fp = fdopen(fd, (char *) mode);
5315
5316   if (fp) {
5317     unsigned int fdoff = fd / sizeof(unsigned int);
5318     struct stat sbuf; /* native stat; we don't need flex_stat */
5319     if (!sockflagsize || fdoff > sockflagsize) {
5320       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
5321       else           New  (1324,sockflags,fdoff+2,unsigned int);
5322       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5323       sockflagsize = fdoff + 2;
5324     }
5325     if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5326       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5327   }
5328   return fp;
5329
5330 }
5331 /*}}}*/
5332
5333
5334 /*
5335  * Clear the corresponding bit when the (possibly) socket stream is closed.
5336  * There still a small hole: we miss an implicit close which might occur
5337  * via freopen().  >> Todo
5338  */
5339 /*{{{ int my_fclose(FILE *fp)*/
5340 int my_fclose(FILE *fp) {
5341   if (fp) {
5342     unsigned int fd = fileno(fp);
5343     unsigned int fdoff = fd / sizeof(unsigned int);
5344
5345     if (sockflagsize && fdoff <= sockflagsize)
5346       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5347   }
5348   return fclose(fp);
5349 }
5350 /*}}}*/
5351
5352
5353 /*
5354  * A simple fwrite replacement which outputs itmsz*nitm chars without
5355  * introducing record boundaries every itmsz chars.
5356  * We are using fputs, which depends on a terminating null.  We may
5357  * well be writing binary data, so we need to accommodate not only
5358  * data with nulls sprinkled in the middle but also data with no null
5359  * byte at the end.
5360  */
5361 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5362 int
5363 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5364 {
5365   register char *cp, *end, *cpd, *data;
5366   register unsigned int fd = fileno(dest);
5367   register unsigned int fdoff = fd / sizeof(unsigned int);
5368   int retval;
5369   int bufsize = itmsz * nitm + 1;
5370
5371   if (fdoff < sockflagsize &&
5372       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5373     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5374     return nitm;
5375   }
5376
5377   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5378   memcpy( data, src, itmsz*nitm );
5379   data[itmsz*nitm] = '\0';
5380
5381   end = data + itmsz * nitm;
5382   retval = (int) nitm; /* on success return # items written */
5383
5384   cpd = data;
5385   while (cpd <= end) {
5386     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5387     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5388     if (cp < end)
5389       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5390     cpd = cp + 1;
5391   }
5392
5393   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5394   return retval;
5395
5396 }  /* end of my_fwrite() */
5397 /*}}}*/
5398
5399 /*{{{ int my_flush(FILE *fp)*/
5400 int
5401 Perl_my_flush(pTHX_ FILE *fp)
5402 {
5403     int res;
5404     if ((res = fflush(fp)) == 0 && fp) {
5405 #ifdef VMS_DO_SOCKETS
5406         Stat_t s;
5407         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5408 #endif
5409             res = fsync(fileno(fp));
5410     }
5411 /*
5412  * If the flush succeeded but set end-of-file, we need to clear
5413  * the error because our caller may check ferror().  BTW, this
5414  * probably means we just flushed an empty file.
5415  */
5416     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5417
5418     return res;
5419 }
5420 /*}}}*/
5421
5422 /*
5423  * Here are replacements for the following Unix routines in the VMS environment:
5424  *      getpwuid    Get information for a particular UIC or UID
5425  *      getpwnam    Get information for a named user
5426  *      getpwent    Get information for each user in the rights database
5427  *      setpwent    Reset search to the start of the rights database
5428  *      endpwent    Finish searching for users in the rights database
5429  *
5430  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5431  * (defined in pwd.h), which contains the following fields:-
5432  *      struct passwd {
5433  *              char        *pw_name;    Username (in lower case)
5434  *              char        *pw_passwd;  Hashed password
5435  *              unsigned int pw_uid;     UIC
5436  *              unsigned int pw_gid;     UIC group  number
5437  *              char        *pw_unixdir; Default device/directory (VMS-style)
5438  *              char        *pw_gecos;   Owner name
5439  *              char        *pw_dir;     Default device/directory (Unix-style)
5440  *              char        *pw_shell;   Default CLI name (eg. DCL)
5441  *      };
5442  * If the specified user does not exist, getpwuid and getpwnam return NULL.
5443  *
5444  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5445  * not the UIC member number (eg. what's returned by getuid()),
5446  * getpwuid() can accept either as input (if uid is specified, the caller's
5447  * UIC group is used), though it won't recognise gid=0.
5448  *
5449  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5450  * information about other users in your group or in other groups, respectively.
5451  * If the required privilege is not available, then these routines fill only
5452  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5453  * string).
5454  *
5455  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5456  */
5457
5458 /* sizes of various UAF record fields */
5459 #define UAI$S_USERNAME 12
5460 #define UAI$S_IDENT    31
5461 #define UAI$S_OWNER    31
5462 #define UAI$S_DEFDEV   31
5463 #define UAI$S_DEFDIR   63
5464 #define UAI$S_DEFCLI   31
5465 #define UAI$S_PWD       8
5466
5467 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
5468                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5469                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
5470
5471 static char __empty[]= "";
5472 static struct passwd __passwd_empty=
5473     {(char *) __empty, (char *) __empty, 0, 0,
5474      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5475 static int contxt= 0;
5476 static struct passwd __pwdcache;
5477 static char __pw_namecache[UAI$S_IDENT+1];
5478
5479 /*
5480  * This routine does most of the work extracting the user information.
5481  */
5482 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5483 {
5484     static struct {
5485         unsigned char length;
5486         char pw_gecos[UAI$S_OWNER+1];
5487     } owner;
5488     static union uicdef uic;
5489     static struct {
5490         unsigned char length;
5491         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5492     } defdev;
5493     static struct {
5494         unsigned char length;
5495         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5496     } defdir;
5497     static struct {
5498         unsigned char length;
5499         char pw_shell[UAI$S_DEFCLI+1];
5500     } defcli;
5501     static char pw_passwd[UAI$S_PWD+1];
5502
5503     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5504     struct dsc$descriptor_s name_desc;
5505     unsigned long int sts;
5506
5507     static struct itmlst_3 itmlst[]= {
5508         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
5509         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
5510         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
5511         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
5512         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
5513         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
5514         {0,                0,           NULL,    NULL}};
5515
5516     name_desc.dsc$w_length=  strlen(name);
5517     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5518     name_desc.dsc$b_class=   DSC$K_CLASS_S;
5519     name_desc.dsc$a_pointer= (char *) name;
5520
5521 /*  Note that sys$getuai returns many fields as counted strings. */
5522     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5523     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5524       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5525     }
5526     else { _ckvmssts(sts); }
5527     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
5528
5529     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
5530     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5531     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5532     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5533     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5534     owner.pw_gecos[lowner]=            '\0';
5535     defdev.pw_dir[ldefdev+ldefdir]= '\0';
5536     defcli.pw_shell[ldefcli]=          '\0';
5537     if (valid_uic(uic)) {
5538         pwd->pw_uid= uic.uic$l_uic;
5539         pwd->pw_gid= uic.uic$v_group;
5540     }
5541     else
5542       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5543     pwd->pw_passwd=  pw_passwd;
5544     pwd->pw_gecos=   owner.pw_gecos;
5545     pwd->pw_dir=     defdev.pw_dir;
5546     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5547     pwd->pw_shell=   defcli.pw_shell;
5548     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5549         int ldir;
5550         ldir= strlen(pwd->pw_unixdir) - 1;
5551         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5552     }
5553     else
5554         strcpy(pwd->pw_unixdir, pwd->pw_dir);
5555     __mystrtolower(pwd->pw_unixdir);
5556     return 1;
5557 }
5558
5559 /*
5560  * Get information for a named user.
5561 */
5562 /*{{{struct passwd *getpwnam(char *name)*/
5563 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5564 {
5565     struct dsc$descriptor_s name_desc;
5566     union uicdef uic;
5567     unsigned long int status, sts;
5568
5569     __pwdcache = __passwd_empty;
5570     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5571       /* We still may be able to determine pw_uid and pw_gid */
5572       name_desc.dsc$w_length=  strlen(name);
5573       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5574       name_desc.dsc$b_class=   DSC$K_CLASS_S;
5575       name_desc.dsc$a_pointer= (char *) name;
5576       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5577         __pwdcache.pw_uid= uic.uic$l_uic;
5578         __pwdcache.pw_gid= uic.uic$v_group;
5579       }
5580       else {
5581         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5582           set_vaxc_errno(sts);
5583           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5584           return NULL;
5585         }
5586         else { _ckvmssts(sts); }
5587       }
5588     }
5589     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5590     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5591     __pwdcache.pw_name= __pw_namecache;
5592     return &__pwdcache;
5593 }  /* end of my_getpwnam() */
5594 /*}}}*/
5595
5596 /*
5597  * Get information for a particular UIC or UID.
5598  * Called by my_getpwent with uid=-1 to list all users.
5599 */
5600 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5601 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5602 {
5603     const $DESCRIPTOR(name_desc,__pw_namecache);
5604     unsigned short lname;
5605     union uicdef uic;
5606     unsigned long int status;
5607
5608     if (uid == (unsigned int) -1) {
5609       do {
5610         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5611         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5612           set_vaxc_errno(status);
5613           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5614           my_endpwent();
5615           return NULL;
5616         }
5617         else { _ckvmssts(status); }
5618       } while (!valid_uic (uic));
5619     }
5620     else {
5621       uic.uic$l_uic= uid;
5622       if (!uic.uic$v_group)
5623         uic.uic$v_group= PerlProc_getgid();
5624       if (valid_uic(uic))
5625         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5626       else status = SS$_IVIDENT;
5627       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5628           status == RMS$_PRV) {
5629         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5630         return NULL;
5631       }
5632       else { _ckvmssts(status); }
5633     }
5634     __pw_namecache[lname]= '\0';
5635     __mystrtolower(__pw_namecache);
5636
5637     __pwdcache = __passwd_empty;
5638     __pwdcache.pw_name = __pw_namecache;
5639
5640 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5641     The identifier's value is usually the UIC, but it doesn't have to be,
5642     so if we can, we let fillpasswd update this. */
5643     __pwdcache.pw_uid =  uic.uic$l_uic;
5644     __pwdcache.pw_gid =  uic.uic$v_group;
5645
5646     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5647     return &__pwdcache;
5648
5649 }  /* end of my_getpwuid() */
5650 /*}}}*/
5651
5652 /*
5653  * Get information for next user.
5654 */
5655 /*{{{struct passwd *my_getpwent()*/
5656 struct passwd *Perl_my_getpwent(pTHX)
5657 {
5658     return (my_getpwuid((unsigned int) -1));
5659 }
5660 /*}}}*/
5661
5662 /*
5663  * Finish searching rights database for users.
5664 */
5665 /*{{{void my_endpwent()*/
5666 void Perl_my_endpwent(pTHX)
5667 {
5668     if (contxt) {
5669       _ckvmssts(sys$finish_rdb(&contxt));
5670       contxt= 0;
5671     }
5672 }
5673 /*}}}*/
5674
5675 #ifdef HOMEGROWN_POSIX_SIGNALS
5676   /* Signal handling routines, pulled into the core from POSIX.xs.
5677    *
5678    * We need these for threads, so they've been rolled into the core,
5679    * rather than left in POSIX.xs.
5680    *
5681    * (DRS, Oct 23, 1997)
5682    */
5683
5684   /* sigset_t is atomic under VMS, so these routines are easy */
5685 /*{{{int my_sigemptyset(sigset_t *) */
5686 int my_sigemptyset(sigset_t *set) {
5687     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5688     *set = 0; return 0;
5689 }
5690 /*}}}*/
5691
5692
5693 /*{{{int my_sigfillset(sigset_t *)*/
5694 int my_sigfillset(sigset_t *set) {
5695     int i;
5696     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5697     for (i = 0; i < NSIG; i++) *set |= (1 << i);
5698     return 0;
5699 }
5700 /*}}}*/
5701
5702
5703 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5704 int my_sigaddset(sigset_t *set, int sig) {
5705     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5706     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5707     *set |= (1 << (sig - 1));
5708     return 0;
5709 }
5710 /*}}}*/
5711
5712
5713 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5714 int my_sigdelset(sigset_t *set, int sig) {
5715     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5716     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5717     *set &= ~(1 << (sig - 1));
5718     return 0;
5719 }
5720 /*}}}*/
5721
5722
5723 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5724 int my_sigismember(sigset_t *set, int sig) {
5725     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5726     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5727     return *set & (1 << (sig - 1));
5728 }
5729 /*}}}*/
5730
5731
5732 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5733 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5734     sigset_t tempmask;
5735
5736     /* If set and oset are both null, then things are badly wrong. Bail out. */
5737     if ((oset == NULL) && (set == NULL)) {
5738       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5739       return -1;
5740     }
5741
5742     /* If set's null, then we're just handling a fetch. */
5743     if (set == NULL) {
5744         tempmask = sigblock(0);
5745     }
5746     else {
5747       switch (how) {
5748       case SIG_SETMASK:
5749         tempmask = sigsetmask(*set);
5750         break;
5751       case SIG_BLOCK:
5752         tempmask = sigblock(*set);
5753         break;
5754       case SIG_UNBLOCK:
5755         tempmask = sigblock(0);
5756         sigsetmask(*oset & ~tempmask);
5757         break;
5758       default:
5759         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5760         return -1;
5761       }
5762     }
5763
5764     /* Did they pass us an oset? If so, stick our holding mask into it */
5765     if (oset)
5766       *oset = tempmask;
5767
5768     return 0;
5769 }
5770 /*}}}*/
5771 #endif  /* HOMEGROWN_POSIX_SIGNALS */
5772
5773
5774 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5775  * my_utime(), and flex_stat(), all of which operate on UTC unless
5776  * VMSISH_TIMES is true.
5777  */
5778 /* method used to handle UTC conversions:
5779  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
5780  */
5781 static int gmtime_emulation_type;
5782 /* number of secs to add to UTC POSIX-style time to get local time */
5783 static long int utc_offset_secs;
5784
5785 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5786  * in vmsish.h.  #undef them here so we can call the CRTL routines
5787  * directly.
5788  */
5789 #undef gmtime
5790 #undef localtime
5791 #undef time
5792
5793
5794 /*
5795  * DEC C previous to 6.0 corrupts the behavior of the /prefix
5796  * qualifier with the extern prefix pragma.  This provisional
5797  * hack circumvents this prefix pragma problem in previous
5798  * precompilers.
5799  */
5800 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5801 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5802 #    pragma __extern_prefix save
5803 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
5804 #    define gmtime decc$__utctz_gmtime
5805 #    define localtime decc$__utctz_localtime
5806 #    define time decc$__utc_time
5807 #    pragma __extern_prefix restore
5808
5809      struct tm *gmtime(), *localtime();
5810
5811 #  endif
5812 #endif
5813
5814
5815 static time_t toutc_dst(time_t loc) {
5816   struct tm *rsltmp;
5817
5818   if ((rsltmp = localtime(&loc)) == NULL) return -1;
5819   loc -= utc_offset_secs;
5820   if (rsltmp->tm_isdst) loc -= 3600;
5821   return loc;
5822 }
5823 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
5824        ((gmtime_emulation_type || my_time(NULL)), \
5825        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5826        ((secs) - utc_offset_secs))))
5827
5828 static time_t toloc_dst(time_t utc) {
5829   struct tm *rsltmp;
5830
5831   utc += utc_offset_secs;
5832   if ((rsltmp = localtime(&utc)) == NULL) return -1;
5833   if (rsltmp->tm_isdst) utc += 3600;
5834   return utc;
5835 }
5836 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
5837        ((gmtime_emulation_type || my_time(NULL)), \
5838        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5839        ((secs) + utc_offset_secs))))
5840
5841 #ifndef RTL_USES_UTC
5842 /*
5843
5844     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
5845         DST starts on 1st sun of april      at 02:00  std time
5846             ends on last sun of october     at 02:00  dst time
5847     see the UCX management command reference, SET CONFIG TIMEZONE
5848     for formatting info.
5849
5850     No, it's not as general as it should be, but then again, NOTHING
5851     will handle UK times in a sensible way.
5852 */
5853
5854
5855 /*
5856     parse the DST start/end info:
5857     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5858 */
5859
5860 static char *
5861 tz_parse_startend(char *s, struct tm *w, int *past)
5862 {
5863     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5864     int ly, dozjd, d, m, n, hour, min, sec, j, k;
5865     time_t g;
5866
5867     if (!s)    return 0;
5868     if (!w) return 0;
5869     if (!past) return 0;
5870
5871     ly = 0;
5872     if (w->tm_year % 4        == 0) ly = 1;
5873     if (w->tm_year % 100      == 0) ly = 0;
5874     if (w->tm_year+1900 % 400 == 0) ly = 1;
5875     if (ly) dinm[1]++;
5876
5877     dozjd = isdigit(*s);
5878     if (*s == 'J' || *s == 'j' || dozjd) {
5879         if (!dozjd && !isdigit(*++s)) return 0;
5880         d = *s++ - '0';
5881         if (isdigit(*s)) {
5882             d = d*10 + *s++ - '0';
5883             if (isdigit(*s)) {
5884                 d = d*10 + *s++ - '0';
5885             }
5886         }
5887         if (d == 0) return 0;
5888         if (d > 366) return 0;
5889         d--;
5890         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
5891         g = d * 86400;
5892         dozjd = 1;
5893     } else if (*s == 'M' || *s == 'm') {
5894         if (!isdigit(*++s)) return 0;
5895         m = *s++ - '0';
5896         if (isdigit(*s)) m = 10*m + *s++ - '0';
5897         if (*s != '.') return 0;
5898         if (!isdigit(*++s)) return 0;
5899         n = *s++ - '0';
5900         if (n < 1 || n > 5) return 0;
5901         if (*s != '.') return 0;
5902         if (!isdigit(*++s)) return 0;
5903         d = *s++ - '0';
5904         if (d > 6) return 0;
5905     }
5906
5907     if (*s == '/') {
5908         if (!isdigit(*++s)) return 0;
5909         hour = *s++ - '0';
5910         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5911         if (*s == ':') {
5912             if (!isdigit(*++s)) return 0;
5913             min = *s++ - '0';
5914             if (isdigit(*s)) min = 10*min + *s++ - '0';
5915             if (*s == ':') {
5916                 if (!isdigit(*++s)) return 0;
5917                 sec = *s++ - '0';
5918                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5919             }
5920         }
5921     } else {
5922         hour = 2;
5923         min = 0;
5924         sec = 0;
5925     }
5926
5927     if (dozjd) {
5928         if (w->tm_yday < d) goto before;
5929         if (w->tm_yday > d) goto after;
5930     } else {
5931         if (w->tm_mon+1 < m) goto before;
5932         if (w->tm_mon+1 > m) goto after;
5933
5934         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
5935         k = d - j; /* mday of first d */
5936         if (k <= 0) k += 7;
5937         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
5938         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5939         if (w->tm_mday < k) goto before;
5940         if (w->tm_mday > k) goto after;
5941     }
5942
5943     if (w->tm_hour < hour) goto before;
5944     if (w->tm_hour > hour) goto after;
5945     if (w->tm_min  < min)  goto before;
5946     if (w->tm_min  > min)  goto after;
5947     if (w->tm_sec  < sec)  goto before;
5948     goto after;
5949
5950 before:
5951     *past = 0;
5952     return s;
5953 after:
5954     *past = 1;
5955     return s;
5956 }
5957
5958
5959
5960
5961 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
5962
5963 static char *
5964 tz_parse_offset(char *s, int *offset)
5965 {
5966     int hour = 0, min = 0, sec = 0;
5967     int neg = 0;
5968     if (!s) return 0;
5969     if (!offset) return 0;
5970
5971     if (*s == '-') {neg++; s++;}
5972     if (*s == '+') s++;
5973     if (!isdigit(*s)) return 0;
5974     hour = *s++ - '0';
5975     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5976     if (hour > 24) return 0;
5977     if (*s == ':') {
5978         if (!isdigit(*++s)) return 0;
5979         min = *s++ - '0';
5980         if (isdigit(*s)) min = min*10 + (*s++ - '0');
5981         if (min > 59) return 0;
5982         if (*s == ':') {
5983             if (!isdigit(*++s)) return 0;
5984             sec = *s++ - '0';
5985             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5986             if (sec > 59) return 0;
5987         }
5988     }
5989
5990     *offset = (hour*60+min)*60 + sec;
5991     if (neg) *offset = -*offset;
5992     return s;
5993 }
5994
5995 /*
5996     input time is w, whatever type of time the CRTL localtime() uses.
5997     sets dst, the zone, and the gmtoff (seconds)
5998
5999     caches the value of TZ and UCX$TZ env variables; note that
6000     my_setenv looks for these and sets a flag if they're changed
6001     for efficiency.
6002
6003     We have to watch out for the "australian" case (dst starts in
6004     october, ends in april)...flagged by "reverse" and checked by
6005     scanning through the months of the previous year.
6006
6007 */
6008
6009 static int
6010 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
6011 {
6012     time_t when;
6013     struct tm *w2;
6014     char *s,*s2;
6015     char *dstzone, *tz, *s_start, *s_end;
6016     int std_off, dst_off, isdst;
6017     int y, dststart, dstend;
6018     static char envtz[1025];  /* longer than any logical, symbol, ... */
6019     static char ucxtz[1025];
6020     static char reversed = 0;
6021
6022     if (!w) return 0;
6023
6024     if (tz_updated) {
6025         tz_updated = 0;
6026         reversed = -1;  /* flag need to check  */
6027         envtz[0] = ucxtz[0] = '\0';
6028         tz = my_getenv("TZ",0);
6029         if (tz) strcpy(envtz, tz);
6030         tz = my_getenv("UCX$TZ",0);
6031         if (tz) strcpy(ucxtz, tz);
6032         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
6033     }
6034     tz = envtz;
6035     if (!*tz) tz = ucxtz;
6036
6037     s = tz;
6038     while (isalpha(*s)) s++;
6039     s = tz_parse_offset(s, &std_off);
6040     if (!s) return 0;
6041     if (!*s) {                  /* no DST, hurray we're done! */
6042         isdst = 0;
6043         goto done;
6044     }
6045
6046     dstzone = s;
6047     while (isalpha(*s)) s++;
6048     s2 = tz_parse_offset(s, &dst_off);
6049     if (s2) {
6050         s = s2;
6051     } else {
6052         dst_off = std_off - 3600;
6053     }
6054
6055     if (!*s) {      /* default dst start/end?? */
6056         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
6057             s = strchr(ucxtz,',');
6058         }
6059         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
6060     }
6061     if (*s != ',') return 0;
6062
6063     when = *w;
6064     when = _toutc(when);      /* convert to utc */
6065     when = when - std_off;    /* convert to pseudolocal time*/
6066
6067     w2 = localtime(&when);
6068     y = w2->tm_year;
6069     s_start = s+1;
6070     s = tz_parse_startend(s_start,w2,&dststart);
6071     if (!s) return 0;
6072     if (*s != ',') return 0;
6073
6074     when = *w;
6075     when = _toutc(when);      /* convert to utc */
6076     when = when - dst_off;    /* convert to pseudolocal time*/
6077     w2 = localtime(&when);
6078     if (w2->tm_year != y) {   /* spans a year, just check one time */
6079         when += dst_off - std_off;
6080         w2 = localtime(&when);
6081     }
6082     s_end = s+1;
6083     s = tz_parse_startend(s_end,w2,&dstend);
6084     if (!s) return 0;
6085
6086     if (reversed == -1) {  /* need to check if start later than end */
6087         int j, ds, de;
6088
6089         when = *w;
6090         if (when < 2*365*86400) {
6091             when += 2*365*86400;
6092         } else {
6093             when -= 365*86400;
6094         }
6095         w2 =localtime(&when);
6096         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
6097
6098         for (j = 0; j < 12; j++) {
6099             w2 =localtime(&when);
6100             (void) tz_parse_startend(s_start,w2,&ds);
6101             (void) tz_parse_startend(s_end,w2,&de);
6102             if (ds != de) break;
6103             when += 30*86400;
6104         }
6105         reversed = 0;
6106         if (de && !ds) reversed = 1;
6107     }
6108
6109     isdst = dststart && !dstend;
6110     if (reversed) isdst = dststart  || !dstend;
6111
6112 done:
6113     if (dst)    *dst = isdst;
6114     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6115     if (isdst)  tz = dstzone;
6116     if (zone) {
6117         while(isalpha(*tz))  *zone++ = *tz++;
6118         *zone = '\0';
6119     }
6120     return 1;
6121 }
6122
6123 #endif /* !RTL_USES_UTC */
6124
6125 /* my_time(), my_localtime(), my_gmtime()
6126  * By default traffic in UTC time values, using CRTL gmtime() or
6127  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6128  * Note: We need to use these functions even when the CRTL has working
6129  * UTC support, since they also handle C<use vmsish qw(times);>
6130  *
6131  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
6132  * Modified by Charles Bailey <bailey@newman.upenn.edu>
6133  */
6134
6135 /*{{{time_t my_time(time_t *timep)*/
6136 time_t Perl_my_time(pTHX_ time_t *timep)
6137 {
6138   time_t when;
6139   struct tm *tm_p;
6140
6141   if (gmtime_emulation_type == 0) {
6142     int dstnow;
6143     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
6144                               /* results of calls to gmtime() and localtime() */
6145                               /* for same &base */
6146
6147     gmtime_emulation_type++;
6148     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6149       char off[LNM$C_NAMLENGTH+1];;
6150
6151       gmtime_emulation_type++;
6152       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6153         gmtime_emulation_type++;
6154         utc_offset_secs = 0;
6155         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6156       }
6157       else { utc_offset_secs = atol(off); }
6158     }
6159     else { /* We've got a working gmtime() */
6160       struct tm gmt, local;
6161
6162       gmt = *tm_p;
6163       tm_p = localtime(&base);
6164       local = *tm_p;
6165       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
6166       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6167       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
6168       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
6169     }
6170   }
6171
6172   when = time(NULL);
6173 # ifdef VMSISH_TIME
6174 # ifdef RTL_USES_UTC
6175   if (VMSISH_TIME) when = _toloc(when);
6176 # else
6177   if (!VMSISH_TIME) when = _toutc(when);
6178 # endif
6179 # endif
6180   if (timep != NULL) *timep = when;
6181   return when;
6182
6183 }  /* end of my_time() */
6184 /*}}}*/
6185
6186
6187 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6188 struct tm *
6189 Perl_my_gmtime(pTHX_ const time_t *timep)
6190 {
6191   char *p;
6192   time_t when;
6193   struct tm *rsltmp;
6194
6195   if (timep == NULL) {
6196     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6197     return NULL;
6198   }
6199   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
6200
6201   when = *timep;
6202 # ifdef VMSISH_TIME
6203   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6204 #  endif
6205 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
6206   return gmtime(&when);
6207 # else
6208   /* CRTL localtime() wants local time as input, so does no tz correction */
6209   rsltmp = localtime(&when);
6210   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
6211   return rsltmp;
6212 #endif
6213 }  /* end of my_gmtime() */
6214 /*}}}*/
6215
6216
6217 /*{{{struct tm *my_localtime(const time_t *timep)*/
6218 struct tm *
6219 Perl_my_localtime(pTHX_ const time_t *timep)
6220 {
6221   time_t when, whenutc;
6222   struct tm *rsltmp;
6223   int dst, offset;
6224
6225   if (timep == NULL) {
6226     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6227     return NULL;
6228   }
6229   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
6230   if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6231
6232   when = *timep;
6233 # ifdef RTL_USES_UTC
6234 # ifdef VMSISH_TIME
6235   if (VMSISH_TIME) when = _toutc(when);
6236 # endif
6237   /* CRTL localtime() wants UTC as input, does tz correction itself */
6238   return localtime(&when);
6239
6240 # else /* !RTL_USES_UTC */
6241   whenutc = when;
6242 # ifdef VMSISH_TIME
6243   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
6244   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
6245 # endif
6246   dst = -1;
6247 #ifndef RTL_USES_UTC
6248   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
6249       when = whenutc - offset;                   /* pseudolocal time*/
6250   }
6251 # endif
6252   /* CRTL localtime() wants local time as input, so does no tz correction */
6253   rsltmp = localtime(&when);
6254   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6255   return rsltmp;
6256 # endif
6257
6258 } /*  end of my_localtime() */
6259 /*}}}*/
6260
6261 /* Reset definitions for later calls */
6262 #define gmtime(t)    my_gmtime(t)
6263 #define localtime(t) my_localtime(t)
6264 #define time(t)      my_time(t)
6265
6266
6267 /* my_utime - update modification time of a file
6268  * calling sequence is identical to POSIX utime(), but under
6269  * VMS only the modification time is changed; ODS-2 does not
6270  * maintain access times.  Restrictions differ from the POSIX
6271  * definition in that the time can be changed as long as the
6272  * caller has permission to execute the necessary IO$_MODIFY $QIO;
6273  * no separate checks are made to insure that the caller is the
6274  * owner of the file or has special privs enabled.
6275  * Code here is based on Joe Meadows' FILE utility.
6276  */
6277
6278 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6279  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
6280  * in 100 ns intervals.
6281  */
6282 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6283
6284 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6285 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6286 {
6287   register int i;
6288   long int bintime[2], len = 2, lowbit, unixtime,
6289            secscale = 10000000; /* seconds --> 100 ns intervals */
6290   unsigned long int chan, iosb[2], retsts;
6291   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6292   struct FAB myfab = cc$rms_fab;
6293   struct NAM mynam = cc$rms_nam;
6294 #if defined (__DECC) && defined (__VAX)
6295   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6296    * at least through VMS V6.1, which causes a type-conversion warning.
6297    */
6298 #  pragma message save
6299 #  pragma message disable cvtdiftypes
6300 #endif
6301   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6302   struct fibdef myfib;
6303 #if defined (__DECC) && defined (__VAX)
6304   /* This should be right after the declaration of myatr, but due
6305    * to a bug in VAX DEC C, this takes effect a statement early.
6306    */
6307 #  pragma message restore
6308 #endif
6309   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6310                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6311                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6312
6313   if (file == NULL || *file == '\0') {
6314     set_errno(ENOENT);
6315     set_vaxc_errno(LIB$_INVARG);
6316     return -1;
6317   }
6318   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6319
6320   if (utimes != NULL) {
6321     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
6322      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6323      * Since time_t is unsigned long int, and lib$emul takes a signed long int
6324      * as input, we force the sign bit to be clear by shifting unixtime right
6325      * one bit, then multiplying by an extra factor of 2 in lib$emul().
6326      */
6327     lowbit = (utimes->modtime & 1) ? secscale : 0;
6328     unixtime = (long int) utimes->modtime;
6329 #   ifdef VMSISH_TIME
6330     /* If input was UTC; convert to local for sys svc */
6331     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6332 #   endif
6333     unixtime >>= 1;  secscale <<= 1;
6334     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6335     if (!(retsts & 1)) {
6336       set_errno(EVMSERR);
6337       set_vaxc_errno(retsts);
6338       return -1;
6339     }
6340     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6341     if (!(retsts & 1)) {
6342       set_errno(EVMSERR);
6343       set_vaxc_errno(retsts);
6344       return -1;
6345     }
6346   }
6347   else {
6348     /* Just get the current time in VMS format directly */
6349     retsts = sys$gettim(bintime);
6350     if (!(retsts & 1)) {
6351       set_errno(EVMSERR);
6352       set_vaxc_errno(retsts);
6353       return -1;
6354     }
6355   }
6356
6357   myfab.fab$l_fna = vmsspec;
6358   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6359   myfab.fab$l_nam = &mynam;
6360   mynam.nam$l_esa = esa;
6361   mynam.nam$b_ess = (unsigned char) sizeof esa;
6362   mynam.nam$l_rsa = rsa;
6363   mynam.nam$b_rss = (unsigned char) sizeof rsa;
6364
6365   /* Look for the file to be affected, letting RMS parse the file
6366    * specification for us as well.  I have set errno using only
6367    * values documented in the utime() man page for VMS POSIX.
6368    */
6369   retsts = sys$parse(&myfab,0,0);
6370   if (!(retsts & 1)) {
6371     set_vaxc_errno(retsts);
6372     if      (retsts == RMS$_PRV) set_errno(EACCES);
6373     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6374     else                         set_errno(EVMSERR);
6375     return -1;
6376   }
6377   retsts = sys$search(&myfab,0,0);
6378   if (!(retsts & 1)) {
6379     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6380     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6381     set_vaxc_errno(retsts);
6382     if      (retsts == RMS$_PRV) set_errno(EACCES);
6383     else if (retsts == RMS$_FNF) set_errno(ENOENT);
6384     else                         set_errno(EVMSERR);
6385     return -1;
6386   }
6387
6388   devdsc.dsc$w_length = mynam.nam$b_dev;
6389   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6390
6391   retsts = sys$assign(&devdsc,&chan,0,0);
6392   if (!(retsts & 1)) {
6393     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6394     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6395     set_vaxc_errno(retsts);
6396     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
6397     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
6398     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
6399     else                               set_errno(EVMSERR);
6400     return -1;
6401   }
6402
6403   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6404   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6405
6406   memset((void *) &myfib, 0, sizeof myfib);
6407 #if defined(__DECC) || defined(__DECCXX)
6408   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6409   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6410   /* This prevents the revision time of the file being reset to the current
6411    * time as a result of our IO$_MODIFY $QIO. */
6412   myfib.fib$l_acctl = FIB$M_NORECORD;
6413 #else
6414   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6415   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6416   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6417 #endif
6418   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6419   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6420   myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6421   _ckvmssts(sys$dassgn(chan));
6422   if (retsts & 1) retsts = iosb[0];
6423   if (!(retsts & 1)) {
6424     set_vaxc_errno(retsts);
6425     if (retsts == SS$_NOPRIV) set_errno(EACCES);
6426     else                      set_errno(EVMSERR);
6427     return -1;
6428   }
6429
6430   return 0;
6431 }  /* end of my_utime() */
6432 /*}}}*/
6433
6434 /*
6435  * flex_stat, flex_fstat
6436  * basic stat, but gets it right when asked to stat
6437  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6438  */
6439
6440 /* encode_dev packs a VMS device name string into an integer to allow
6441  * simple comparisons. This can be used, for example, to check whether two
6442  * files are located on the same device, by comparing their encoded device
6443  * names. Even a string comparison would not do, because stat() reuses the
6444  * device name buffer for each call; so without encode_dev, it would be
6445  * necessary to save the buffer and use strcmp (this would mean a number of
6446  * changes to the standard Perl code, to say nothing of what a Perl script
6447  * would have to do.
6448  *
6449  * The device lock id, if it exists, should be unique (unless perhaps compared
6450  * with lock ids transferred from other nodes). We have a lock id if the disk is
6451  * mounted cluster-wide, which is when we tend to get long (host-qualified)
6452  * device names. Thus we use the lock id in preference, and only if that isn't
6453  * available, do we try to pack the device name into an integer (flagged by
6454  * the sign bit (LOCKID_MASK) being set).
6455  *
6456  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6457  * name and its encoded form, but it seems very unlikely that we will find
6458  * two files on different disks that share the same encoded device names,
6459  * and even more remote that they will share the same file id (if the test
6460  * is to check for the same file).
6461  *
6462  * A better method might be to use sys$device_scan on the first call, and to
6463  * search for the device, returning an index into the cached array.
6464  * The number returned would be more intelligable.
6465  * This is probably not worth it, and anyway would take quite a bit longer
6466  * on the first call.
6467  */
6468 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
6469 static mydev_t encode_dev (pTHX_ const char *dev)
6470 {
6471   int i;
6472   unsigned long int f;
6473   mydev_t enc;
6474   char c;
6475   const char *q;
6476
6477   if (!dev || !dev[0]) return 0;
6478
6479 #if LOCKID_MASK
6480   {
6481     struct dsc$descriptor_s dev_desc;
6482     unsigned long int status, lockid, item = DVI$_LOCKID;
6483
6484     /* For cluster-mounted disks, the disk lock identifier is unique, so we
6485        can try that first. */
6486     dev_desc.dsc$w_length =  strlen (dev);
6487     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
6488     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
6489     dev_desc.dsc$a_pointer = (char *) dev;
6490     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6491     if (lockid) return (lockid & ~LOCKID_MASK);
6492   }
6493 #endif
6494
6495   /* Otherwise we try to encode the device name */
6496   enc = 0;
6497   f = 1;
6498   i = 0;
6499   for (q = dev + strlen(dev); q--; q >= dev) {
6500     if (isdigit (*q))
6501       c= (*q) - '0';
6502     else if (isalpha (toupper (*q)))
6503       c= toupper (*q) - 'A' + (char)10;
6504     else
6505       continue; /* Skip '$'s */
6506     i++;
6507     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
6508     if (i>1) f *= 36;
6509     enc += f * (unsigned long int) c;
6510   }
6511   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
6512
6513 }  /* end of encode_dev() */
6514
6515 static char namecache[NAM$C_MAXRSS+1];
6516
6517 static int
6518 is_null_device(name)
6519     const char *name;
6520 {
6521     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6522        The underscore prefix, controller letter, and unit number are
6523        independently optional; for our purposes, the colon punctuation
6524        is not.  The colon can be trailed by optional directory and/or
6525        filename, but two consecutive colons indicates a nodename rather
6526        than a device.  [pr]  */
6527   if (*name == '_') ++name;
6528   if (tolower(*name++) != 'n') return 0;
6529   if (tolower(*name++) != 'l') return 0;
6530   if (tolower(*name) == 'a') ++name;
6531   if (*name == '0') ++name;
6532   return (*name++ == ':') && (*name != ':');
6533 }
6534
6535 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
6536 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6537  * subset of the applicable information.
6538  */
6539 bool
6540 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6541 {
6542   char fname_phdev[NAM$C_MAXRSS+1];
6543   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6544   else {
6545     char fname[NAM$C_MAXRSS+1];
6546     unsigned long int retsts;
6547     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6548                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6549
6550     /* If the struct mystat is stale, we're OOL; stat() overwrites the
6551        device name on successive calls */
6552     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6553     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6554     namdsc.dsc$a_pointer = fname;
6555     namdsc.dsc$w_length = sizeof fname - 1;
6556
6557     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6558                              &namdsc,&namdsc.dsc$w_length,0,0);
6559     if (retsts & 1) {
6560       fname[namdsc.dsc$w_length] = '\0';
6561 /*
6562  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6563  * but if someone has redefined that logical, Perl gets very lost.  Since
6564  * we have the physical device name from the stat buffer, just paste it on.
6565  */
6566       strcpy( fname_phdev, statbufp->st_devnam );
6567       strcat( fname_phdev, strrchr(fname, ':') );
6568
6569       return cando_by_name(bit,effective,fname_phdev);
6570     }
6571     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6572       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6573       return FALSE;
6574     }
6575     _ckvmssts(retsts);
6576     return FALSE;  /* Should never get to here */
6577   }
6578 }  /* end of cando() */
6579 /*}}}*/
6580
6581
6582 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6583 I32
6584 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6585 {
6586   static char usrname[L_cuserid];
6587   static struct dsc$descriptor_s usrdsc =
6588          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6589   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6590   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6591   unsigned short int retlen, trnlnm_iter_count;
6592   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6593   union prvdef curprv;
6594   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6595          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6596   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6597          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6598          {0,0,0,0}};
6599   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6600          {0,0,0,0}};
6601   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6602
6603   if (!fname || !*fname) return FALSE;
6604   /* Make sure we expand logical names, since sys$check_access doesn't */
6605   if (!strpbrk(fname,"/]>:")) {
6606     strcpy(fileified,fname);
6607     trnlnm_iter_count = 0;
6608     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
6609         trnlnm_iter_count++;
6610         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6611     }
6612     fname = fileified;
6613   }
6614   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6615   retlen = namdsc.dsc$w_length = strlen(vmsname);
6616   namdsc.dsc$a_pointer = vmsname;
6617   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6618       vmsname[retlen-1] == ':') {
6619     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6620     namdsc.dsc$w_length = strlen(fileified);
6621     namdsc.dsc$a_pointer = fileified;
6622   }
6623
6624   switch (bit) {
6625     case S_IXUSR: case S_IXGRP: case S_IXOTH:
6626       access = ARM$M_EXECUTE; break;
6627     case S_IRUSR: case S_IRGRP: case S_IROTH:
6628       access = ARM$M_READ; break;
6629     case S_IWUSR: case S_IWGRP: case S_IWOTH:
6630       access = ARM$M_WRITE; break;
6631     case S_IDUSR: case S_IDGRP: case S_IDOTH:
6632       access = ARM$M_DELETE; break;
6633     default:
6634       return FALSE;
6635   }
6636
6637   /* Before we call $check_access, create a user profile with the current
6638    * process privs since otherwise it just uses the default privs from the
6639    * UAF and might give false positives or negatives.
6640    */
6641
6642   /* get current process privs and username */
6643   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6644   _ckvmssts(iosb[0]);
6645
6646   /* find out the space required for the profile */
6647   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6648                                     &usrprodsc.dsc$w_length,0));
6649
6650   /* allocate space for the profile and get it filled in */
6651   New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6652   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6653                                     &usrprodsc.dsc$w_length,0));
6654
6655   /* use the profile to check access to the file; free profile & analyze results */
6656   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6657   Safefree(usrprodsc.dsc$a_pointer);
6658   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6659   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
6660       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6661       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6662     set_vaxc_errno(retsts);
6663     if (retsts == SS$_NOPRIV) set_errno(EACCES);
6664     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6665     else set_errno(ENOENT);
6666     return FALSE;
6667   }
6668   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6669     return TRUE;
6670   }
6671   _ckvmssts(retsts);
6672
6673   return FALSE;  /* Should never get here */
6674
6675 }  /* end of cando_by_name() */
6676 /*}}}*/
6677
6678
6679 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6680 int
6681 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6682 {
6683   if (!fstat(fd,(stat_t *) statbufp)) {
6684     if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6685     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6686 #   ifdef RTL_USES_UTC
6687 #   ifdef VMSISH_TIME
6688     if (VMSISH_TIME) {
6689       statbufp->st_mtime = _toloc(statbufp->st_mtime);
6690       statbufp->st_atime = _toloc(statbufp->st_atime);
6691       statbufp->st_ctime = _toloc(statbufp->st_ctime);
6692     }
6693 #   endif
6694 #   else
6695 #   ifdef VMSISH_TIME
6696     if (!VMSISH_TIME) { /* Return UTC instead of local time */
6697 #   else
6698     if (1) {
6699 #   endif
6700       statbufp->st_mtime = _toutc(statbufp->st_mtime);
6701       statbufp->st_atime = _toutc(statbufp->st_atime);
6702       statbufp->st_ctime = _toutc(statbufp->st_ctime);
6703     }
6704 #endif
6705     return 0;
6706   }
6707   return -1;
6708
6709 }  /* end of flex_fstat() */
6710 /*}}}*/
6711
6712 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6713 int
6714 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6715 {
6716     char fileified[NAM$C_MAXRSS+1];
6717     char temp_fspec[NAM$C_MAXRSS+300];
6718     int retval = -1;
6719     int saved_errno, saved_vaxc_errno;
6720
6721     if (!fspec) return retval;
6722     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6723     strcpy(temp_fspec, fspec);
6724     if (statbufp == (Stat_t *) &PL_statcache)
6725       do_tovmsspec(temp_fspec,namecache,0);
6726     if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6727       memset(statbufp,0,sizeof *statbufp);
6728       statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6729       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6730       statbufp->st_uid = 0x00010001;
6731       statbufp->st_gid = 0x0001;
6732       time((time_t *)&statbufp->st_mtime);
6733       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6734       return 0;
6735     }
6736
6737     /* Try for a directory name first.  If fspec contains a filename without
6738      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6739      * and sea:[wine.dark]water. exist, we prefer the directory here.
6740      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6741      * not sea:[wine.dark]., if the latter exists.  If the intended target is
6742      * the file with null type, specify this by calling flex_stat() with
6743      * a '.' at the end of fspec.
6744      */
6745     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6746       retval = stat(fileified,(stat_t *) statbufp);
6747       if (!retval && statbufp == (Stat_t *) &PL_statcache)
6748         strcpy(namecache,fileified);
6749     }
6750     if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6751     if (!retval) {
6752       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6753 #     ifdef RTL_USES_UTC
6754 #     ifdef VMSISH_TIME
6755       if (VMSISH_TIME) {
6756         statbufp->st_mtime = _toloc(statbufp->st_mtime);
6757         statbufp->st_atime = _toloc(statbufp->st_atime);
6758         statbufp->st_ctime = _toloc(statbufp->st_ctime);
6759       }
6760 #     endif
6761 #     else
6762 #     ifdef VMSISH_TIME
6763       if (!VMSISH_TIME) { /* Return UTC instead of local time */
6764 #     else
6765       if (1) {
6766 #     endif
6767         statbufp->st_mtime = _toutc(statbufp->st_mtime);
6768         statbufp->st_atime = _toutc(statbufp->st_atime);
6769         statbufp->st_ctime = _toutc(statbufp->st_ctime);
6770       }
6771 #     endif
6772     }
6773     /* If we were successful, leave errno where we found it */
6774     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6775     return retval;
6776
6777 }  /* end of flex_stat() */
6778 /*}}}*/
6779
6780
6781 /*{{{char *my_getlogin()*/
6782 /* VMS cuserid == Unix getlogin, except calling sequence */
6783 char *
6784 my_getlogin()
6785 {
6786     static char user[L_cuserid];
6787     return cuserid(user);
6788 }
6789 /*}}}*/
6790
6791
6792 /*  rmscopy - copy a file using VMS RMS routines
6793  *
6794  *  Copies contents and attributes of spec_in to spec_out, except owner
6795  *  and protection information.  Name and type of spec_in are used as
6796  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
6797  *  should try to propagate timestamps from the input file to the output file.
6798  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
6799  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
6800  *  propagated to the output file at creation iff the output file specification
6801  *  did not contain an explicit name or type, and the revision date is always
6802  *  updated at the end of the copy operation.  If it is greater than 0, then
6803  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6804  *  other than the revision date should be propagated, and bit 1 indicates
6805  *  that the revision date should be propagated.
6806  *
6807  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6808  *
6809  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6810  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
6811  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
6812  * as part of the Perl standard distribution under the terms of the
6813  * GNU General Public License or the Perl Artistic License.  Copies
6814  * of each may be found in the Perl standard distribution.
6815  */
6816 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6817 int
6818 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6819 {
6820     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6821          rsa[NAM$C_MAXRSS], ubf[32256];
6822     unsigned long int i, sts, sts2;
6823     struct FAB fab_in, fab_out;
6824     struct RAB rab_in, rab_out;
6825     struct NAM nam;
6826     struct XABDAT xabdat;
6827     struct XABFHC xabfhc;
6828     struct XABRDT xabrdt;
6829     struct XABSUM xabsum;
6830
6831     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
6832         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6833       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6834       return 0;
6835     }
6836
6837     fab_in = cc$rms_fab;
6838     fab_in.fab$l_fna = vmsin;
6839     fab_in.fab$b_fns = strlen(vmsin);
6840     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6841     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6842     fab_in.fab$l_fop = FAB$M_SQO;
6843     fab_in.fab$l_nam =  &nam;
6844     fab_in.fab$l_xab = (void *) &xabdat;
6845
6846     nam = cc$rms_nam;
6847     nam.nam$l_rsa = rsa;
6848     nam.nam$b_rss = sizeof(rsa);
6849     nam.nam$l_esa = esa;
6850     nam.nam$b_ess = sizeof (esa);
6851     nam.nam$b_esl = nam.nam$b_rsl = 0;
6852
6853     xabdat = cc$rms_xabdat;        /* To get creation date */
6854     xabdat.xab$l_nxt = (void *) &xabfhc;
6855
6856     xabfhc = cc$rms_xabfhc;        /* To get record length */
6857     xabfhc.xab$l_nxt = (void *) &xabsum;
6858
6859     xabsum = cc$rms_xabsum;        /* To get key and area information */
6860
6861     if (!((sts = sys$open(&fab_in)) & 1)) {
6862       set_vaxc_errno(sts);
6863       switch (sts) {
6864         case RMS$_FNF: case RMS$_DNF:
6865           set_errno(ENOENT); break;
6866         case RMS$_DIR:
6867           set_errno(ENOTDIR); break;
6868         case RMS$_DEV:
6869           set_errno(ENODEV); break;
6870         case RMS$_SYN:
6871           set_errno(EINVAL); break;
6872         case RMS$_PRV:
6873           set_errno(EACCES); break;
6874         default:
6875           set_errno(EVMSERR);
6876       }
6877       return 0;
6878     }
6879
6880     fab_out = fab_in;
6881     fab_out.fab$w_ifi = 0;
6882     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6883     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6884     fab_out.fab$l_fop = FAB$M_SQO;
6885     fab_out.fab$l_fna = vmsout;
6886     fab_out.fab$b_fns = strlen(vmsout);
6887     fab_out.fab$l_dna = nam.nam$l_name;
6888     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6889
6890     if (preserve_dates == 0) {  /* Act like DCL COPY */
6891       nam.nam$b_nop = NAM$M_SYNCHK;
6892       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
6893       if (!((sts = sys$parse(&fab_out)) & 1)) {
6894         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6895         set_vaxc_errno(sts);
6896         return 0;
6897       }
6898       fab_out.fab$l_xab = (void *) &xabdat;
6899       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6900     }
6901     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
6902     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
6903       preserve_dates =0;      /* bitmask from this point forward   */
6904
6905     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6906     if (!((sts = sys$create(&fab_out)) & 1)) {
6907       set_vaxc_errno(sts);
6908       switch (sts) {
6909         case RMS$_DNF:
6910           set_errno(ENOENT); break;
6911         case RMS$_DIR:
6912           set_errno(ENOTDIR); break;
6913         case RMS$_DEV:
6914           set_errno(ENODEV); break;
6915         case RMS$_SYN:
6916           set_errno(EINVAL); break;
6917         case RMS$_PRV:
6918           set_errno(EACCES); break;
6919         default:
6920           set_errno(EVMSERR);
6921       }
6922       return 0;
6923     }
6924     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
6925     if (preserve_dates & 2) {
6926       /* sys$close() will process xabrdt, not xabdat */
6927       xabrdt = cc$rms_xabrdt;
6928 #ifndef __GNUC__
6929       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6930 #else
6931       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6932        * is unsigned long[2], while DECC & VAXC use a struct */
6933       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6934 #endif
6935       fab_out.fab$l_xab = (void *) &xabrdt;
6936     }
6937
6938     rab_in = cc$rms_rab;
6939     rab_in.rab$l_fab = &fab_in;
6940     rab_in.rab$l_rop = RAB$M_BIO;
6941     rab_in.rab$l_ubf = ubf;
6942     rab_in.rab$w_usz = sizeof ubf;
6943     if (!((sts = sys$connect(&rab_in)) & 1)) {
6944       sys$close(&fab_in); sys$close(&fab_out);
6945       set_errno(EVMSERR); set_vaxc_errno(sts);
6946       return 0;
6947     }
6948
6949     rab_out = cc$rms_rab;
6950     rab_out.rab$l_fab = &fab_out;
6951     rab_out.rab$l_rbf = ubf;
6952     if (!((sts = sys$connect(&rab_out)) & 1)) {
6953       sys$close(&fab_in); sys$close(&fab_out);
6954       set_errno(EVMSERR); set_vaxc_errno(sts);
6955       return 0;
6956     }
6957
6958     while ((sts = sys$read(&rab_in))) {  /* always true  */
6959       if (sts == RMS$_EOF) break;
6960       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6961       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6962         sys$close(&fab_in); sys$close(&fab_out);
6963         set_errno(EVMSERR); set_vaxc_errno(sts);
6964         return 0;
6965       }
6966     }
6967
6968     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
6969     sys$close(&fab_in);  sys$close(&fab_out);
6970     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6971     if (!(sts & 1)) {
6972       set_errno(EVMSERR); set_vaxc_errno(sts);
6973       return 0;
6974     }
6975
6976     return 1;
6977
6978 }  /* end of rmscopy() */
6979 /*}}}*/
6980
6981
6982 /***  The following glue provides 'hooks' to make some of the routines
6983  * from this file available from Perl.  These routines are sufficiently
6984  * basic, and are required sufficiently early in the build process,
6985  * that's it's nice to have them available to miniperl as well as the
6986  * full Perl, so they're set up here instead of in an extension.  The
6987  * Perl code which handles importation of these names into a given
6988  * package lives in [.VMS]Filespec.pm in @INC.
6989  */
6990
6991 void
6992 rmsexpand_fromperl(pTHX_ CV *cv)
6993 {
6994   dXSARGS;
6995   char *fspec, *defspec = NULL, *rslt;
6996   STRLEN n_a;
6997
6998   if (!items || items > 2)
6999     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
7000   fspec = SvPV(ST(0),n_a);
7001   if (!fspec || !*fspec) XSRETURN_UNDEF;
7002   if (items == 2) defspec = SvPV(ST(1),n_a);
7003
7004   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
7005   ST(0) = sv_newmortal();
7006   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
7007   XSRETURN(1);
7008 }
7009
7010 void
7011 vmsify_fromperl(pTHX_ CV *cv)
7012 {
7013   dXSARGS;
7014   char *vmsified;
7015   STRLEN n_a;
7016
7017   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
7018   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
7019   ST(0) = sv_newmortal();
7020   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7021   XSRETURN(1);
7022 }
7023
7024 void
7025 unixify_fromperl(pTHX_ CV *cv)
7026 {
7027   dXSARGS;
7028   char *unixified;
7029   STRLEN n_a;
7030
7031   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7032   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7033   ST(0) = sv_newmortal();
7034   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7035   XSRETURN(1);
7036 }
7037
7038 void
7039 fileify_fromperl(pTHX_ CV *cv)
7040 {
7041   dXSARGS;
7042   char *fileified;
7043   STRLEN n_a;
7044
7045   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7046   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7047   ST(0) = sv_newmortal();
7048   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7049   XSRETURN(1);
7050 }
7051
7052 void
7053 pathify_fromperl(pTHX_ CV *cv)
7054 {
7055   dXSARGS;
7056   char *pathified;
7057   STRLEN n_a;
7058
7059   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7060   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7061   ST(0) = sv_newmortal();
7062   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7063   XSRETURN(1);
7064 }
7065
7066 void
7067 vmspath_fromperl(pTHX_ CV *cv)
7068 {
7069   dXSARGS;
7070   char *vmspath;
7071   STRLEN n_a;
7072
7073   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7074   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7075   ST(0) = sv_newmortal();
7076   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7077   XSRETURN(1);
7078 }
7079
7080 void
7081 unixpath_fromperl(pTHX_ CV *cv)
7082 {
7083   dXSARGS;
7084   char *unixpath;
7085   STRLEN n_a;
7086
7087   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7088   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7089   ST(0) = sv_newmortal();
7090   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7091   XSRETURN(1);
7092 }
7093
7094 void
7095 candelete_fromperl(pTHX_ CV *cv)
7096 {
7097   dXSARGS;
7098   char fspec[NAM$C_MAXRSS+1], *fsp;
7099   SV *mysv;
7100   IO *io;
7101   STRLEN n_a;
7102
7103   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7104
7105   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7106   if (SvTYPE(mysv) == SVt_PVGV) {
7107     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7108       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7109       ST(0) = &PL_sv_no;
7110       XSRETURN(1);
7111     }
7112     fsp = fspec;
7113   }
7114   else {
7115     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7116       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7117       ST(0) = &PL_sv_no;
7118       XSRETURN(1);
7119     }
7120   }
7121
7122   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7123   XSRETURN(1);
7124 }
7125
7126 void
7127 rmscopy_fromperl(pTHX_ CV *cv)
7128 {
7129   dXSARGS;
7130   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7131   int date_flag;
7132   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7133                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7134   unsigned long int sts;
7135   SV *mysv;
7136   IO *io;
7137   STRLEN n_a;
7138
7139   if (items < 2 || items > 3)
7140     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7141
7142   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7143   if (SvTYPE(mysv) == SVt_PVGV) {
7144     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7145       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7146       ST(0) = &PL_sv_no;
7147       XSRETURN(1);
7148     }
7149     inp = inspec;
7150   }
7151   else {
7152     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7153       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7154       ST(0) = &PL_sv_no;
7155       XSRETURN(1);
7156     }
7157   }
7158   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7159   if (SvTYPE(mysv) == SVt_PVGV) {
7160     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7161       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7162       ST(0) = &PL_sv_no;
7163       XSRETURN(1);
7164     }
7165     outp = outspec;
7166   }
7167   else {
7168     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7169       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7170       ST(0) = &PL_sv_no;
7171       XSRETURN(1);
7172     }
7173   }
7174   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7175
7176   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7177   XSRETURN(1);
7178 }
7179
7180
7181 void
7182 mod2fname(pTHX_ CV *cv)
7183 {
7184   dXSARGS;
7185   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7186        workbuff[NAM$C_MAXRSS*1 + 1];
7187   int total_namelen = 3, counter, num_entries;
7188   /* ODS-5 ups this, but we want to be consistent, so... */
7189   int max_name_len = 39;
7190   AV *in_array = (AV *)SvRV(ST(0));
7191
7192   num_entries = av_len(in_array);
7193
7194   /* All the names start with PL_. */
7195   strcpy(ultimate_name, "PL_");
7196
7197   /* Clean up our working buffer */
7198   Zero(work_name, sizeof(work_name), char);
7199
7200   /* Run through the entries and build up a working name */
7201   for(counter = 0; counter <= num_entries; counter++) {
7202     /* If it's not the first name then tack on a __ */
7203     if (counter) {
7204       strcat(work_name, "__");
7205     }
7206     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7207                            PL_na));
7208   }
7209
7210   /* Check to see if we actually have to bother...*/
7211   if (strlen(work_name) + 3 <= max_name_len) {
7212     strcat(ultimate_name, work_name);
7213   } else {
7214     /* It's too darned big, so we need to go strip. We use the same */
7215     /* algorithm as xsubpp does. First, strip out doubled __ */
7216     char *source, *dest, last;
7217     dest = workbuff;
7218     last = 0;
7219     for (source = work_name; *source; source++) {
7220       if (last == *source && last == '_') {
7221         continue;
7222       }
7223       *dest++ = *source;
7224       last = *source;
7225     }
7226     /* Go put it back */
7227     strcpy(work_name, workbuff);
7228     /* Is it still too big? */
7229     if (strlen(work_name) + 3 > max_name_len) {
7230       /* Strip duplicate letters */
7231       last = 0;
7232       dest = workbuff;
7233       for (source = work_name; *source; source++) {
7234         if (last == toupper(*source)) {
7235         continue;
7236         }
7237         *dest++ = *source;
7238         last = toupper(*source);
7239       }
7240       strcpy(work_name, workbuff);
7241     }
7242
7243     /* Is it *still* too big? */
7244     if (strlen(work_name) + 3 > max_name_len) {
7245       /* Too bad, we truncate */
7246       work_name[max_name_len - 2] = 0;
7247     }
7248     strcat(ultimate_name, work_name);
7249   }
7250
7251   /* Okay, return it */
7252   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7253   XSRETURN(1);
7254 }
7255
7256 void
7257 hushexit_fromperl(pTHX_ CV *cv)
7258 {
7259     dXSARGS;
7260
7261     if (items > 0) {
7262         VMSISH_HUSHED = SvTRUE(ST(0));
7263     }
7264     ST(0) = boolSV(VMSISH_HUSHED);
7265     XSRETURN(1);
7266 }
7267
7268 void
7269 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7270                           struct interp_intern *dst)
7271 {
7272     memcpy(dst,src,sizeof(struct interp_intern));
7273 }
7274
7275 void
7276 Perl_sys_intern_clear(pTHX)
7277 {
7278 }
7279
7280 void
7281 Perl_sys_intern_init(pTHX)
7282 {
7283     unsigned int ix = RAND_MAX;
7284     double x;
7285
7286     VMSISH_HUSHED = 0;
7287
7288     x = (float)ix;
7289     MY_INV_RAND_MAX = 1./x;
7290 }
7291
7292 void
7293 init_os_extras()
7294 {
7295   dTHX;
7296   char* file = __FILE__;
7297   char temp_buff[512];
7298   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7299     no_translate_barewords = TRUE;
7300   } else {
7301     no_translate_barewords = FALSE;
7302   }
7303
7304   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7305   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7306   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7307   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7308   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7309   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7310   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7311   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7312   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7313   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7314   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7315
7316   store_pipelocs(aTHX);         /* will redo any earlier attempts */
7317
7318   return;
7319 }
7320
7321 /*  End of vms.c */