vms/vms.c

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