vms/vms.c

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