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_cmd0\n");
2043     fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd1\n");
2044     fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd2\n");
2045     fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd3\n");
2046     fprintf(fp,"$ perl_on\n");
2047     fprintf(fp,"$ 'c\n");
2048     fprintf(fp,"$ perl_status = $STATUS\n");
2049     fprintf(fp,"$ perl_del  'perl_cfile'\n");
2050     fprintf(fp,"$ perl_exit 'perl_status'\n");
2051     fsync(fileno(fp));
2052
2053     fgetname(fp, file, 1);
2054     fstat(fileno(fp), &s0);
2055     fclose(fp);
2056
2057     fp = fopen(file,"r","shr=get");
2058     if (!fp) return 0;
2059     fstat(fileno(fp), &s1);
2060
2061     if (s0.st_ino[0] != s1.st_ino[0] ||
2062         s0.st_ino[1] != s1.st_ino[1] ||
2063         s0.st_ino[2] != s1.st_ino[2] ||
2064         s0.st_ctime  != s1.st_ctime  )  {
2065         fclose(fp);
2066         return 0;
2067     }
2068
2069     return fp;
2070 }
2071
2072
2073
2074 static PerlIO *
2075 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2076 {
2077     static int handler_set_up = FALSE;
2078     unsigned long int sts, flags=1;  /* nowait - gnu c doesn't allow &1 */
2079     unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2080     int j, wait = 0;
2081     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2082     char in[512], out[512], err[512], mbx[512];
2083     FILE *tpipe = 0;
2084     char tfilebuf[NAM$C_MAXRSS+1];
2085     pInfo info;
2086     char cmd_sym_name[20];
2087     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2088                                       DSC$K_CLASS_S, symbol};
2089     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2090                                       DSC$K_CLASS_S, 0};
2091     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2092                                       DSC$K_CLASS_S, cmd_sym_name};
2093     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2094     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2095     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2096
2097     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
2098
2099     /* once-per-program initialization...
2100        note that the SETAST calls and the dual test of pipe_ef
2101        makes sure that only the FIRST thread through here does
2102        the initialization...all other threads wait until it's
2103        done.
2104
2105        Yeah, uglier than a pthread call, it's got all the stuff inline
2106        rather than in a separate routine.
2107     */
2108
2109     if (!pipe_ef) {
2110         _ckvmssts(sys$setast(0));
2111         if (!pipe_ef) {
2112             unsigned long int pidcode = JPI$_PID;
2113             $DESCRIPTOR(d_delay, RETRY_DELAY);
2114             _ckvmssts(lib$get_ef(&pipe_ef));
2115             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2116             _ckvmssts(sys$bintim(&d_delay, delaytime));
2117         }
2118         if (!handler_set_up) {
2119           _ckvmssts(sys$dclexh(&pipe_exitblock));
2120           handler_set_up = TRUE;
2121         }
2122         _ckvmssts(sys$setast(1));
2123     }
2124
2125     /* see if we can find a VMSPIPE.COM */
2126
2127     tfilebuf[0] = '@';
2128     vmspipe = find_vmspipe(aTHX);
2129     if (vmspipe) {
2130         strcpy(tfilebuf+1,vmspipe);
2131     } else {        /* uh, oh...we're in tempfile hell */
2132         tpipe = vmspipe_tempfile(aTHX);
2133         if (!tpipe) {       /* a fish popular in Boston */
2134             if (ckWARN(WARN_PIPE)) {
2135                 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2136             }
2137         return Nullfp;
2138         }
2139         fgetname(tpipe,tfilebuf+1,1);
2140     }
2141     vmspipedsc.dsc$a_pointer = tfilebuf;
2142     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
2143
2144     sts = setup_cmddsc(aTHX_ cmd,0,0);
2145     if (!(sts & 1)) {
2146       switch (sts) {
2147         case RMS$_FNF:  case RMS$_DNF:
2148           set_errno(ENOENT); break;
2149         case RMS$_DIR:
2150           set_errno(ENOTDIR); break;
2151         case RMS$_DEV:
2152           set_errno(ENODEV); break;
2153         case RMS$_PRV:
2154           set_errno(EACCES); break;
2155         case RMS$_SYN:
2156           set_errno(EINVAL); break;
2157         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2158           set_errno(E2BIG); break;
2159         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2160           _ckvmssts(sts); /* fall through */
2161         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2162           set_errno(EVMSERR);
2163       }
2164       set_vaxc_errno(sts);
2165       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2166         Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2167       }
2168       *psts = sts;
2169       return Nullfp;
2170     }
2171     New(1301,info,1,Info);
2172
2173     strcpy(mode,in_mode);
2174     info->mode = *mode;
2175     info->done = FALSE;
2176     info->completion = 0;
2177     info->closing    = FALSE;
2178     info->in         = 0;
2179     info->out        = 0;
2180     info->err        = 0;
2181     info->fp         = Nullfp;
2182     info->useFILE    = 0;
2183     info->waiting    = 0;
2184     info->in_done    = TRUE;
2185     info->out_done   = TRUE;
2186     info->err_done   = TRUE;
2187     in[0] = out[0] = err[0] = '\0';
2188
2189     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
2190         info->useFILE = 1;
2191         strcpy(p,p+1);
2192     }
2193     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
2194         wait = 1;
2195         strcpy(p,p+1);
2196     }
2197
2198     if (*mode == 'r') {             /* piping from subroutine */
2199
2200         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2201         if (info->out) {
2202             info->out->pipe_done = &info->out_done;
2203             info->out_done = FALSE;
2204             info->out->info = info;
2205         }
2206         if (!info->useFILE) {
2207         info->fp  = PerlIO_open(mbx, mode);
2208         } else {
2209             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2210             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2211         }
2212
2213         if (!info->fp && info->out) {
2214             sys$cancel(info->out->chan_out);
2215
2216             while (!info->out_done) {
2217                 int done;
2218                 _ckvmssts(sys$setast(0));
2219                 done = info->out_done;
2220                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2221                 _ckvmssts(sys$setast(1));
2222                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2223             }
2224
2225             if (info->out->buf) Safefree(info->out->buf);
2226             Safefree(info->out);
2227             Safefree(info);
2228             *psts = RMS$_FNF;
2229             return Nullfp;
2230         }
2231
2232         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2233         if (info->err) {
2234             info->err->pipe_done = &info->err_done;
2235             info->err_done = FALSE;
2236             info->err->info = info;
2237         }
2238
2239     } else if (*mode == 'w') {      /* piping to subroutine */
2240
2241         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2242         if (info->out) {
2243             info->out->pipe_done = &info->out_done;
2244             info->out_done = FALSE;
2245             info->out->info = info;
2246         }
2247
2248         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2249         if (info->err) {
2250             info->err->pipe_done = &info->err_done;
2251             info->err_done = FALSE;
2252             info->err->info = info;
2253         }
2254
2255         info->in = pipe_tochild_setup(aTHX_ in,mbx);
2256         if (!info->useFILE) {
2257         info->fp  = PerlIO_open(mbx, mode);
2258         } else {
2259             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2260             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2261         }
2262
2263         if (info->in) {
2264             info->in->pipe_done = &info->in_done;
2265             info->in_done = FALSE;
2266             info->in->info = info;
2267         }
2268
2269         /* error cleanup */
2270         if (!info->fp && info->in) {
2271             info->done = TRUE;
2272             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2273                               0, 0, 0, 0, 0, 0, 0, 0));
2274
2275             while (!info->in_done) {
2276                 int done;
2277                 _ckvmssts(sys$setast(0));
2278                 done = info->in_done;
2279                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2280                 _ckvmssts(sys$setast(1));
2281                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2282             }
2283
2284             if (info->in->buf) Safefree(info->in->buf);
2285             Safefree(info->in);
2286             Safefree(info);
2287             *psts = RMS$_FNF;
2288             return Nullfp;
2289         }
2290
2291
2292     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
2293         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2294         if (info->out) {
2295             info->out->pipe_done = &info->out_done;
2296             info->out_done = FALSE;
2297             info->out->info = info;
2298         }
2299
2300         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2301         if (info->err) {
2302             info->err->pipe_done = &info->err_done;
2303             info->err_done = FALSE;
2304             info->err->info = info;
2305         }
2306     }
2307
2308     symbol[MAX_DCL_SYMBOL] = '\0';
2309
2310     strncpy(symbol, in, MAX_DCL_SYMBOL);
2311     d_symbol.dsc$w_length = strlen(symbol);
2312     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2313
2314     strncpy(symbol, err, MAX_DCL_SYMBOL);
2315     d_symbol.dsc$w_length = strlen(symbol);
2316     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2317
2318     strncpy(symbol, out, MAX_DCL_SYMBOL);
2319     d_symbol.dsc$w_length = strlen(symbol);
2320     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2321
2322     p = VMSCMD.dsc$a_pointer;
2323     while (*p && *p != '\n') p++;
2324     *p = '\0';                                  /* truncate on \n */
2325     p = VMSCMD.dsc$a_pointer;
2326     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
2327     if (*p == '$') p++;                         /* remove leading $ */
2328     while (*p == ' ' || *p == '\t') p++;
2329
2330     for (j = 0; j < 4; j++) {
2331         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2332         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2333
2334     strncpy(symbol, p, MAX_DCL_SYMBOL);
2335     d_symbol.dsc$w_length = strlen(symbol);
2336     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2337
2338         if (strlen(p) > MAX_DCL_SYMBOL) {
2339             p += MAX_DCL_SYMBOL;
2340         } else {
2341             p += strlen(p);
2342         }
2343     }
2344     _ckvmssts(sys$setast(0));
2345     info->next=open_pipes;  /* prepend to list */
2346     open_pipes=info;
2347     _ckvmssts(sys$setast(1));
2348     _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2349                       0, &info->pid, &info->completion,
2350                       0, popen_completion_ast,info,0,0,0));
2351
2352     /* if we were using a tempfile, close it now */
2353
2354     if (tpipe) fclose(tpipe);
2355
2356     /* once the subprocess is spawned, it has copied the symbols and
2357        we can get rid of ours */
2358
2359     for (j = 0; j < 4; j++) {
2360         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2361         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2362     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2363     }
2364     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
2365     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2366     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2367     vms_execfree(aTHX);
2368
2369     PL_forkprocess = info->pid;
2370     if (wait) {
2371          int done = 0;
2372          while (!done) {
2373              _ckvmssts(sys$setast(0));
2374              done = info->done;
2375              if (!done) _ckvmssts(sys$clref(pipe_ef));
2376              _ckvmssts(sys$setast(1));
2377              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2378          }
2379         *psts = info->completion;
2380         my_pclose(info->fp);
2381     } else {
2382         *psts = SS$_NORMAL;
2383     }
2384     return info->fp;
2385 }  /* end of safe_popen */
2386
2387
2388 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
2389 PerlIO *
2390 Perl_my_popen(pTHX_ char *cmd, char *mode)
2391 {
2392     int sts;
2393     TAINT_ENV();
2394     TAINT_PROPER("popen");
2395     PERL_FLUSHALL_FOR_CHILD;
2396     return safe_popen(aTHX_ cmd,mode,&sts);
2397 }
2398
2399 /*}}}*/
2400
2401 /*{{{  I32 my_pclose(PerlIO *fp)*/
2402 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2403 {
2404     pInfo info, last = NULL;
2405     unsigned long int retsts;
2406     int done, iss;
2407
2408     for (info = open_pipes; info != NULL; last = info, info = info->next)
2409         if (info->fp == fp) break;
2410
2411     if (info == NULL) {  /* no such pipe open */
2412       set_errno(ECHILD); /* quoth POSIX */
2413       set_vaxc_errno(SS$_NONEXPR);
2414       return -1;
2415     }
2416
2417     /* If we were writing to a subprocess, insure that someone reading from
2418      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
2419      * produce an EOF record in the mailbox.
2420      *
2421      *  well, at least sometimes it *does*, so we have to watch out for
2422      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
2423      */
2424      if (info->fp) {
2425         if (!info->useFILE)
2426      PerlIO_flush(info->fp);   /* first, flush data */
2427         else
2428             fflush((FILE *)info->fp);
2429     }
2430
2431     _ckvmssts(sys$setast(0));
2432      info->closing = TRUE;
2433      done = info->done && info->in_done && info->out_done && info->err_done;
2434      /* hanging on write to Perl's input? cancel it */
2435      if (info->mode == 'r' && info->out && !info->out_done) {
2436         if (info->out->chan_out) {
2437             _ckvmssts(sys$cancel(info->out->chan_out));
2438             if (!info->out->chan_in) {   /* EOF generation, need AST */
2439                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2440             }
2441         }
2442      }
2443      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
2444          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2445                            0, 0, 0, 0, 0, 0));
2446     _ckvmssts(sys$setast(1));
2447     if (info->fp) {
2448      if (!info->useFILE)
2449     PerlIO_close(info->fp);
2450      else
2451         fclose((FILE *)info->fp);
2452     }
2453      /*
2454         we have to wait until subprocess completes, but ALSO wait until all
2455         the i/o completes...otherwise we'll be freeing the "info" structure
2456         that the i/o ASTs could still be using...
2457      */
2458
2459      while (!done) {
2460          _ckvmssts(sys$setast(0));
2461          done = info->done && info->in_done && info->out_done && info->err_done;
2462          if (!done) _ckvmssts(sys$clref(pipe_ef));
2463          _ckvmssts(sys$setast(1));
2464          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2465      }
2466      retsts = info->completion;
2467
2468     /* remove from list of open pipes */
2469     _ckvmssts(sys$setast(0));
2470     if (last) last->next = info->next;
2471     else open_pipes = info->next;
2472     _ckvmssts(sys$setast(1));
2473
2474     /* free buffers and structures */
2475
2476     if (info->in) {
2477         if (info->in->buf) Safefree(info->in->buf);
2478         Safefree(info->in);
2479     }
2480     if (info->out) {
2481         if (info->out->buf) Safefree(info->out->buf);
2482         Safefree(info->out);
2483     }
2484     if (info->err) {
2485         if (info->err->buf) Safefree(info->err->buf);
2486         Safefree(info->err);
2487     }
2488     Safefree(info);
2489
2490     return retsts;
2491
2492 }  /* end of my_pclose() */
2493
2494 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2495   /* Roll our own prototype because we want this regardless of whether
2496    * _VMS_WAIT is defined.
2497    */
2498   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2499 #endif
2500 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2501    created with popen(); otherwise partially emulate waitpid() unless
2502    we have a suitable one from the CRTL that came with VMS 7.2 and later.
2503    Also check processes not considered by the CRTL waitpid().
2504  */
2505 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2506 Pid_t
2507 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2508 {
2509     pInfo info;
2510     int done;
2511     int sts;
2512
2513     if (statusp) *statusp = 0;
2514
2515     for (info = open_pipes; info != NULL; info = info->next)
2516         if (info->pid == pid) break;
2517
2518     if (info != NULL) {  /* we know about this child */
2519       while (!info->done) {
2520           _ckvmssts(sys$setast(0));
2521           done = info->done;
2522           if (!done) _ckvmssts(sys$clref(pipe_ef));
2523           _ckvmssts(sys$setast(1));
2524           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2525       }
2526
2527       if (statusp) *statusp = info->completion;
2528       return pid;
2529
2530     }
2531     else {  /* this child is not one of our own pipe children */
2532
2533 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2534
2535       /* waitpid() became available in the CRTL as of VMS 7.0, but only
2536        * in 7.2 did we get a version that fills in the VMS completion
2537        * status as Perl has always tried to do.
2538        */
2539
2540       sts = __vms_waitpid( pid, statusp, flags );
2541
2542       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2543          return sts;
2544
2545       /* If the real waitpid tells us the child does not exist, we
2546        * fall through here to implement waiting for a child that
2547        * was created by some means other than exec() (say, spawned
2548        * from DCL) or to wait for a process that is not a subprocess
2549        * of the current process.
2550        */
2551
2552 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2553
2554       $DESCRIPTOR(intdsc,"0 00:00:01");
2555       unsigned long int ownercode = JPI$_OWNER, ownerpid;
2556       unsigned long int pidcode = JPI$_PID, mypid;
2557       unsigned long int interval[2];
2558       int termination_mbu = 0;
2559       unsigned short qio_iosb[4];
2560       unsigned int jpi_iosb[2];
2561       struct itmlst_3 jpilist[3] = {
2562           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
2563           {sizeof(termination_mbu), JPI$_TMBU,  &termination_mbu, 0},
2564           {                      0,         0,                 0, 0}
2565       };
2566       char trmmbx[NAM$C_DVI+1];
2567       $DESCRIPTOR(trmmbxdsc,trmmbx);
2568       struct accdef trmmsg;
2569       unsigned short int mbxchan;
2570
2571       if (pid <= 0) {
2572         /* Sorry folks, we don't presently implement rooting around for
2573            the first child we can find, and we definitely don't want to
2574            pass a pid of -1 to $getjpi, where it is a wildcard operation.
2575          */
2576         set_errno(ENOTSUP);
2577         return -1;
2578       }
2579
2580       /* Get the owner of the child so I can warn if it's not mine, plus
2581        * get the termination mailbox.  If the process doesn't exist or I
2582        * don't have the privs to look at it, I can go home early.
2583        */
2584       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2585       if (sts & 1) sts = jpi_iosb[0];
2586       if (!(sts & 1)) {
2587         switch (sts) {
2588             case SS$_NONEXPR:
2589                 set_errno(ECHILD);
2590                 break;
2591             case SS$_NOPRIV:
2592                 set_errno(EACCES);
2593                 break;
2594             default:
2595                 _ckvmssts(sts);
2596         }
2597         set_vaxc_errno(sts);
2598         return -1;
2599       }
2600
2601       if (ckWARN(WARN_EXEC)) {
2602         /* remind folks they are asking for non-standard waitpid behavior */
2603         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2604         if (ownerpid != mypid)
2605           Perl_warner(aTHX_ WARN_EXEC,
2606                       "waitpid: process %x is not a child of process %x",
2607                       pid,mypid);
2608       }
2609
2610       /* It's possible to have a mailbox unit number but no actual mailbox; we
2611        * check for this by assigning a channel to it, which we need anyway.
2612        */
2613       if (termination_mbu != 0) {
2614           sprintf(trmmbx, "MBA%d:", termination_mbu);
2615           trmmbxdsc.dsc$w_length = strlen(trmmbx);
2616           sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
2617           if (sts == SS$_NOSUCHDEV) {
2618               termination_mbu = 0; /* set up to take "no mailbox" case */
2619               sts = SS$_NORMAL;
2620           }
2621           _ckvmssts(sts);
2622       }
2623       /* If the process doesn't have a termination mailbox, then simply check
2624        * on it once a second until it's not there anymore.
2625        */
2626       if (termination_mbu == 0) {
2627           _ckvmssts(sys$bintim(&intdsc,interval));
2628           while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2629             _ckvmssts(sys$schdwk(0,0,interval,0));
2630             _ckvmssts(sys$hiber());
2631           }
2632           if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2633       }
2634       else {
2635         /* If we do have a termination mailbox, post reads to it until we get a
2636          * termination message, discarding messages of the wrong type or for other
2637          * processes.  If there is a place to put the final status, then do so.
2638          */
2639           sts = SS$_NORMAL;
2640           while (sts & 1) {
2641               memset((void *) &trmmsg, 0, sizeof(trmmsg));
2642               sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
2643                              &trmmsg,ACC$K_TERMLEN,0,0,0,0);
2644               if (sts & 1) sts = qio_iosb[0];
2645
2646               if ( sts & 1
2647                    && trmmsg.acc$w_msgtyp == MSG$_DELPROC
2648                    && trmmsg.acc$l_pid == pid ) {
2649
2650                   if (statusp) *statusp = trmmsg.acc$l_finalsts;
2651                   sts = sys$dassgn(mbxchan);
2652                   break;
2653               }
2654           }
2655       } /* termination_mbu ? */
2656
2657       _ckvmssts(sts);
2658       return pid;
2659
2660     } /* else one of our own pipe children */
2661
2662 }  /* end of waitpid() */
2663 /*}}}*/
2664 /*}}}*/
2665 /*}}}*/
2666
2667 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2668 char *
2669 my_gconvert(double val, int ndig, int trail, char *buf)
2670 {
2671   static char __gcvtbuf[DBL_DIG+1];
2672   char *loc;
2673
2674   loc = buf ? buf : __gcvtbuf;
2675
2676 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
2677   if (val < 1) {
2678     sprintf(loc,"%.*g",ndig,val);
2679     return loc;
2680   }
2681 #endif
2682
2683   if (val) {
2684     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2685     return gcvt(val,ndig,loc);
2686   }
2687   else {
2688     loc[0] = '0'; loc[1] = '\0';
2689     return loc;
2690   }
2691
2692 }
2693 /*}}}*/
2694
2695
2696 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2697 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2698  * to expand file specification.  Allows for a single default file
2699  * specification and a simple mask of options.  If outbuf is non-NULL,
2700  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2701  * the resultant file specification is placed.  If outbuf is NULL, the
2702  * resultant file specification is placed into a static buffer.
2703  * The third argument, if non-NULL, is taken to be a default file
2704  * specification string.  The fourth argument is unused at present.
2705  * rmesexpand() returns the address of the resultant string if
2706  * successful, and NULL on error.
2707  */
2708 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2709
2710 static char *
2711 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2712 {
2713   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2714   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2715   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2716   struct FAB myfab = cc$rms_fab;
2717   struct NAM mynam = cc$rms_nam;
2718   STRLEN speclen;
2719   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2720
2721   if (!filespec || !*filespec) {
2722     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2723     return NULL;
2724   }
2725   if (!outbuf) {
2726     if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2727     else    outbuf = __rmsexpand_retbuf;
2728   }
2729   if ((isunix = (strchr(filespec,'/') != NULL))) {
2730     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2731     filespec = vmsfspec;
2732   }
2733
2734   myfab.fab$l_fna = filespec;
2735   myfab.fab$b_fns = strlen(filespec);
2736   myfab.fab$l_nam = &mynam;
2737
2738   if (defspec && *defspec) {
2739     if (strchr(defspec,'/') != NULL) {
2740       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2741       defspec = tmpfspec;
2742     }
2743     myfab.fab$l_dna = defspec;
2744     myfab.fab$b_dns = strlen(defspec);
2745   }
2746
2747   mynam.nam$l_esa = esa;
2748   mynam.nam$b_ess = sizeof esa;
2749   mynam.nam$l_rsa = outbuf;
2750   mynam.nam$b_rss = NAM$C_MAXRSS;
2751
2752   retsts = sys$parse(&myfab,0,0);
2753   if (!(retsts & 1)) {
2754     mynam.nam$b_nop |= NAM$M_SYNCHK;
2755     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2756       retsts = sys$parse(&myfab,0,0);
2757       if (retsts & 1) goto expanded;
2758     }
2759     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2760     (void) sys$parse(&myfab,0,0);  /* Free search context */
2761     if (out) Safefree(out);
2762     set_vaxc_errno(retsts);
2763     if      (retsts == RMS$_PRV) set_errno(EACCES);
2764     else if (retsts == RMS$_DEV) set_errno(ENODEV);
2765     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2766     else                         set_errno(EVMSERR);
2767     return NULL;
2768   }
2769   retsts = sys$search(&myfab,0,0);
2770   if (!(retsts & 1) && retsts != RMS$_FNF) {
2771     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2772     myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
2773     if (out) Safefree(out);
2774     set_vaxc_errno(retsts);
2775     if      (retsts == RMS$_PRV) set_errno(EACCES);
2776     else                         set_errno(EVMSERR);
2777     return NULL;
2778   }
2779
2780   /* If the input filespec contained any lowercase characters,
2781    * downcase the result for compatibility with Unix-minded code. */
2782   expanded:
2783   for (out = myfab.fab$l_fna; *out; out++)
2784     if (islower(*out)) { haslower = 1; break; }
2785   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2786   else                 { out = esa;    speclen = mynam.nam$b_esl; }
2787   /* Trim off null fields added by $PARSE
2788    * If type > 1 char, must have been specified in original or default spec
2789    * (not true for version; $SEARCH may have added version of existing file).
2790    */
2791   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2792   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2793              (mynam.nam$l_ver - mynam.nam$l_type == 1);
2794   if (trimver || trimtype) {
2795     if (defspec && *defspec) {
2796       char defesa[NAM$C_MAXRSS];
2797       struct FAB deffab = cc$rms_fab;
2798       struct NAM defnam = cc$rms_nam;
2799
2800       deffab.fab$l_nam = &defnam;
2801       deffab.fab$l_fna = defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
2802       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
2803       defnam.nam$b_nop = NAM$M_SYNCHK;
2804       if (sys$parse(&deffab,0,0) & 1) {
2805         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2806         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2807       }
2808     }
2809     if (trimver) speclen = mynam.nam$l_ver - out;
2810     if (trimtype) {
2811       /* If we didn't already trim version, copy down */
2812       if (speclen > mynam.nam$l_ver - out)
2813         memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2814                speclen - (mynam.nam$l_ver - out));
2815       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2816     }
2817   }
2818   /* If we just had a directory spec on input, $PARSE "helpfully"
2819    * adds an empty name and type for us */
2820   if (mynam.nam$l_name == mynam.nam$l_type &&
2821       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
2822       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2823     speclen = mynam.nam$l_name - out;
2824   out[speclen] = '\0';
2825   if (haslower) __mystrtolower(out);
2826
2827   /* Have we been working with an expanded, but not resultant, spec? */
2828   /* Also, convert back to Unix syntax if necessary. */
2829   if (!mynam.nam$b_rsl) {
2830     if (isunix) {
2831       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2832     }
2833     else strcpy(outbuf,esa);
2834   }
2835   else if (isunix) {
2836     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2837     strcpy(outbuf,tmpfspec);
2838   }
2839   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2840   mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2841   myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
2842   return outbuf;
2843 }
2844 /*}}}*/
2845 /* External entry points */
2846 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2847 { return do_rmsexpand(spec,buf,0,def,opt); }
2848 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2849 { return do_rmsexpand(spec,buf,1,def,opt); }
2850
2851
2852 /*
2853 ** The following routines are provided to make life easier when
2854 ** converting among VMS-style and Unix-style directory specifications.
2855 ** All will take input specifications in either VMS or Unix syntax. On
2856 ** failure, all return NULL.  If successful, the routines listed below
2857 ** return a pointer to a buffer containing the appropriately
2858 ** reformatted spec (and, therefore, subsequent calls to that routine
2859 ** will clobber the result), while the routines of the same names with
2860 ** a _ts suffix appended will return a pointer to a mallocd string
2861 ** containing the appropriately reformatted spec.
2862 ** In all cases, only explicit syntax is altered; no check is made that
2863 ** the resulting string is valid or that the directory in question
2864 ** actually exists.
2865 **
2866 **   fileify_dirspec() - convert a directory spec into the name of the
2867 **     directory file (i.e. what you can stat() to see if it's a dir).
2868 **     The style (VMS or Unix) of the result is the same as the style
2869 **     of the parameter passed in.
2870 **   pathify_dirspec() - convert a directory spec into a path (i.e.
2871 **     what you prepend to a filename to indicate what directory it's in).
2872 **     The style (VMS or Unix) of the result is the same as the style
2873 **     of the parameter passed in.
2874 **   tounixpath() - convert a directory spec into a Unix-style path.
2875 **   tovmspath() - convert a directory spec into a VMS-style path.
2876 **   tounixspec() - convert any file spec into a Unix-style file spec.
2877 **   tovmsspec() - convert any file spec into a VMS-style spec.
2878 **
2879 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
2880 ** Permission is given to distribute this code as part of the Perl
2881 ** standard distribution under the terms of the GNU General Public
2882 ** License or the Perl Artistic License.  Copies of each may be
2883 ** found in the Perl standard distribution.
2884  */
2885
2886 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2887 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2888 {
2889     static char __fileify_retbuf[NAM$C_MAXRSS+1];
2890     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2891     char *retspec, *cp1, *cp2, *lastdir;
2892     char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2893
2894     if (!dir || !*dir) {
2895       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2896     }
2897     dirlen = strlen(dir);
2898     while (dirlen && dir[dirlen-1] == '/') --dirlen;
2899     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2900       strcpy(trndir,"/sys$disk/000000");
2901       dir = trndir;
2902       dirlen = 16;
2903     }
2904     if (dirlen > NAM$C_MAXRSS) {
2905       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2906     }
2907     if (!strpbrk(dir+1,"/]>:")) {
2908       strcpy(trndir,*dir == '/' ? dir + 1: dir);
2909       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2910       dir = trndir;
2911       dirlen = strlen(dir);
2912     }
2913     else {
2914       strncpy(trndir,dir,dirlen);
2915       trndir[dirlen] = '\0';
2916       dir = trndir;
2917     }
2918     /* If we were handed a rooted logical name or spec, treat it like a
2919      * simple directory, so that
2920      *    $ Define myroot dev:[dir.]
2921      *    ... do_fileify_dirspec("myroot",buf,1) ...
2922      * does something useful.
2923      */
2924     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2925       dir[--dirlen] = '\0';
2926       dir[dirlen-1] = ']';
2927     }
2928     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
2929       dir[--dirlen] = '\0';
2930       dir[dirlen-1] = '>';
2931     }
2932
2933     if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2934       /* If we've got an explicit filename, we can just shuffle the string. */
2935       if (*(cp1+1)) hasfilename = 1;
2936       /* Similarly, we can just back up a level if we've got multiple levels
2937          of explicit directories in a VMS spec which ends with directories. */
2938       else {
2939         for (cp2 = cp1; cp2 > dir; cp2--) {
2940           if (*cp2 == '.') {
2941             *cp2 = *cp1; *cp1 = '\0';
2942             hasfilename = 1;
2943             break;
2944           }
2945           if (*cp2 == '[' || *cp2 == '<') break;
2946         }
2947       }
2948     }
2949
2950     if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2951       if (dir[0] == '.') {
2952         if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2953           return do_fileify_dirspec("[]",buf,ts);
2954         else if (dir[1] == '.' &&
2955                  (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2956           return do_fileify_dirspec("[-]",buf,ts);
2957       }
2958       if (dirlen && dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
2959         dirlen -= 1;                 /* to last element */
2960         lastdir = strrchr(dir,'/');
2961       }
2962       else if ((cp1 = strstr(dir,"/.")) != NULL) {
2963         /* If we have "/." or "/..", VMSify it and let the VMS code
2964          * below expand it, rather than repeating the code to handle
2965          * relative components of a filespec here */
2966         do {
2967           if (*(cp1+2) == '.') cp1++;
2968           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2969             if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2970             if (strchr(vmsdir,'/') != NULL) {
2971               /* If do_tovmsspec() returned it, it must have VMS syntax
2972                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
2973                * the time to check this here only so we avoid a recursion
2974                * loop; otherwise, gigo.
2975                */
2976               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
2977             }
2978             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2979             return do_tounixspec(trndir,buf,ts);
2980           }
2981           cp1++;
2982         } while ((cp1 = strstr(cp1,"/.")) != NULL);
2983         lastdir = strrchr(dir,'/');
2984       }
2985       else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2986         /* Ditto for specs that end in an MFD -- let the VMS code
2987          * figure out whether it's a real device or a rooted logical. */
2988         dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2989         if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2990         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2991         return do_tounixspec(trndir,buf,ts);
2992       }
2993       else {
2994         if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2995              !(lastdir = cp1 = strrchr(dir,']')) &&
2996              !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2997         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
2998           int ver; char *cp3;
2999           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3000               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3001               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3002               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3003               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3004                             (ver || *cp3)))))) {
3005             set_errno(ENOTDIR);
3006             set_vaxc_errno(RMS$_DIR);
3007             return NULL;
3008           }
3009           dirlen = cp2 - dir;
3010         }
3011       }
3012       /* If we lead off with a device or rooted logical, add the MFD
3013          if we're specifying a top-level directory. */
3014       if (lastdir && *dir == '/') {
3015         addmfd = 1;
3016         for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
3017           if (*cp1 == '/') {
3018             addmfd = 0;
3019             break;
3020           }
3021         }
3022       }
3023       retlen = dirlen + (addmfd ? 13 : 6);
3024       if (buf) retspec = buf;
3025       else if (ts) New(1309,retspec,retlen+1,char);
3026       else retspec = __fileify_retbuf;
3027       if (addmfd) {
3028         dirlen = lastdir - dir;
3029         memcpy(retspec,dir,dirlen);
3030         strcpy(&retspec[dirlen],"/000000");
3031         strcpy(&retspec[dirlen+7],lastdir);
3032       }
3033       else {
3034         memcpy(retspec,dir,dirlen);
3035         retspec[dirlen] = '\0';
3036       }
3037       /* We've picked up everything up to the directory file name.
3038          Now just add the type and version, and we're set. */
3039       strcat(retspec,".dir;1");
3040       return retspec;
3041     }
3042     else {  /* VMS-style directory spec */
3043       char esa[NAM$C_MAXRSS+1], term, *cp;
3044       unsigned long int sts, cmplen, haslower = 0;
3045       struct FAB dirfab = cc$rms_fab;
3046       struct NAM savnam, dirnam = cc$rms_nam;
3047
3048       dirfab.fab$b_fns = strlen(dir);
3049       dirfab.fab$l_fna = dir;
3050       dirfab.fab$l_nam = &dirnam;
3051       dirfab.fab$l_dna = ".DIR;1";
3052       dirfab.fab$b_dns = 6;
3053       dirnam.nam$b_ess = NAM$C_MAXRSS;
3054       dirnam.nam$l_esa = esa;
3055
3056       for (cp = dir; *cp; cp++)
3057         if (islower(*cp)) { haslower = 1; break; }
3058       if (!((sts = sys$parse(&dirfab))&1)) {
3059         if (dirfab.fab$l_sts == RMS$_DIR) {
3060           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3061           sts = sys$parse(&dirfab) & 1;
3062         }
3063         if (!sts) {
3064           set_errno(EVMSERR);
3065           set_vaxc_errno(dirfab.fab$l_sts);
3066           return NULL;
3067         }
3068       }
3069       else {
3070         savnam = dirnam;
3071         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
3072           /* Yes; fake the fnb bits so we'll check type below */
3073           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3074         }
3075         else { /* No; just work with potential name */
3076           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3077           else {
3078             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
3079             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3080             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3081             return NULL;
3082           }
3083         }
3084       }
3085       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3086         cp1 = strchr(esa,']');
3087         if (!cp1) cp1 = strchr(esa,'>');
3088         if (cp1) {  /* Should always be true */
3089           dirnam.nam$b_esl -= cp1 - esa - 1;
3090           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3091         }
3092       }
3093       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3094         /* Yep; check version while we're at it, if it's there. */
3095         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3096         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3097           /* Something other than .DIR[;1].  Bzzt. */
3098           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3099           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3100           set_errno(ENOTDIR);
3101           set_vaxc_errno(RMS$_DIR);
3102           return NULL;
3103         }
3104       }
3105       esa[dirnam.nam$b_esl] = '\0';
3106       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3107         /* They provided at least the name; we added the type, if necessary, */
3108         if (buf) retspec = buf;                            /* in sys$parse() */
3109         else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3110         else retspec = __fileify_retbuf;
3111         strcpy(retspec,esa);
3112         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3113         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3114         return retspec;
3115       }
3116       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3117         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3118         *cp1 = '\0';
3119         dirnam.nam$b_esl -= 9;
3120       }
3121       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3122       if (cp1 == NULL) { /* should never happen */
3123         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3124         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3125         return NULL;
3126       }
3127       term = *cp1;
3128       *cp1 = '\0';
3129       retlen = strlen(esa);
3130       if ((cp1 = strrchr(esa,'.')) != NULL) {
3131         /* There's more than one directory in the path.  Just roll back. */
3132         *cp1 = term;
3133         if (buf) retspec = buf;
3134         else if (ts) New(1311,retspec,retlen+7,char);
3135         else retspec = __fileify_retbuf;
3136         strcpy(retspec,esa);
3137       }
3138       else {
3139         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3140           /* Go back and expand rooted logical name */
3141           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3142           if (!(sys$parse(&dirfab) & 1)) {
3143             dirnam.nam$l_rlf = NULL;
3144             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3145             set_errno(EVMSERR);
3146             set_vaxc_errno(dirfab.fab$l_sts);
3147             return NULL;
3148           }
3149           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3150           if (buf) retspec = buf;
3151           else if (ts) New(1312,retspec,retlen+16,char);
3152           else retspec = __fileify_retbuf;
3153           cp1 = strstr(esa,"][");
3154           if (!cp1) cp1 = strstr(esa,"]<");
3155           dirlen = cp1 - esa;
3156           memcpy(retspec,esa,dirlen);
3157           if (!strncmp(cp1+2,"000000]",7)) {
3158             retspec[dirlen-1] = '\0';
3159             for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3160             if (*cp1 == '.') *cp1 = ']';
3161             else {
3162               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3163               memcpy(cp1+1,"000000]",7);
3164             }
3165           }
3166           else {
3167             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3168             retspec[retlen] = '\0';
3169             /* Convert last '.' to ']' */
3170             for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3171             if (*cp1 == '.') *cp1 = ']';
3172             else {
3173               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3174               memcpy(cp1+1,"000000]",7);
3175             }
3176           }
3177         }
3178         else {  /* This is a top-level dir.  Add the MFD to the path. */
3179           if (buf) retspec = buf;
3180           else if (ts) New(1312,retspec,retlen+16,char);
3181           else retspec = __fileify_retbuf;
3182           cp1 = esa;
3183           cp2 = retspec;
3184           while (*cp1 != ':') *(cp2++) = *(cp1++);
3185           strcpy(cp2,":[000000]");
3186           cp1 += 2;
3187           strcpy(cp2+9,cp1);
3188         }
3189       }
3190       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3191       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3192       /* We've set up the string up through the filename.  Add the
3193          type and version, and we're done. */
3194       strcat(retspec,".DIR;1");
3195
3196       /* $PARSE may have upcased filespec, so convert output to lower
3197        * case if input contained any lowercase characters. */
3198       if (haslower) __mystrtolower(retspec);
3199       return retspec;
3200     }
3201 }  /* end of do_fileify_dirspec() */
3202 /*}}}*/
3203 /* External entry points */
3204 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3205 { return do_fileify_dirspec(dir,buf,0); }
3206 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3207 { return do_fileify_dirspec(dir,buf,1); }
3208
3209 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3210 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3211 {
3212     static char __pathify_retbuf[NAM$C_MAXRSS+1];
3213     unsigned long int retlen;
3214     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3215
3216     if (!dir || !*dir) {
3217       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3218     }
3219
3220     if (*dir) strcpy(trndir,dir);
3221     else getcwd(trndir,sizeof trndir - 1);
3222
3223     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3224            && my_trnlnm(trndir,trndir,0)) {
3225       STRLEN trnlen = strlen(trndir);
3226
3227       /* Trap simple rooted lnms, and return lnm:[000000] */
3228       if (!strcmp(trndir+trnlen-2,".]")) {
3229         if (buf) retpath = buf;
3230         else if (ts) New(1318,retpath,strlen(dir)+10,char);
3231         else retpath = __pathify_retbuf;
3232         strcpy(retpath,dir);
3233         strcat(retpath,":[000000]");
3234         return retpath;
3235       }
3236     }
3237     dir = trndir;
3238
3239     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3240       if (*dir == '.' && (*(dir+1) == '\0' ||
3241                           (*(dir+1) == '.' && *(dir+2) == '\0')))
3242         retlen = 2 + (*(dir+1) != '\0');
3243       else {
3244         if ( !(cp1 = strrchr(dir,'/')) &&
3245              !(cp1 = strrchr(dir,']')) &&
3246              !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3247         if ((cp2 = strchr(cp1,'.')) != NULL &&
3248             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
3249              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
3250               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3251               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3252           int ver; char *cp3;
3253           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3254               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3255               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3256               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3257               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3258                             (ver || *cp3)))))) {
3259             set_errno(ENOTDIR);
3260             set_vaxc_errno(RMS$_DIR);
3261             return NULL;
3262           }
3263           retlen = cp2 - dir + 1;
3264         }
3265         else {  /* No file type present.  Treat the filename as a directory. */
3266           retlen = strlen(dir) + 1;
3267         }
3268       }
3269       if (buf) retpath = buf;
3270       else if (ts) New(1313,retpath,retlen+1,char);
3271       else retpath = __pathify_retbuf;
3272       strncpy(retpath,dir,retlen-1);
3273       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3274         retpath[retlen-1] = '/';      /* with '/', add it. */
3275         retpath[retlen] = '\0';
3276       }
3277       else retpath[retlen-1] = '\0';
3278     }
3279     else {  /* VMS-style directory spec */
3280       char esa[NAM$C_MAXRSS+1], *cp;
3281       unsigned long int sts, cmplen, haslower;
3282       struct FAB dirfab = cc$rms_fab;
3283       struct NAM savnam, dirnam = cc$rms_nam;
3284
3285       /* If we've got an explicit filename, we can just shuffle the string. */
3286       if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3287              (cp1 = strrchr(dir,'>')) != NULL     ) && *(cp1+1)) {
3288         if ((cp2 = strchr(cp1,'.')) != NULL) {
3289           int ver; char *cp3;
3290           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3291               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3292               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3293               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3294               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3295                             (ver || *cp3)))))) {
3296             set_errno(ENOTDIR);
3297             set_vaxc_errno(RMS$_DIR);
3298             return NULL;
3299           }
3300         }
3301         else {  /* No file type, so just draw name into directory part */
3302           for (cp2 = cp1; *cp2; cp2++) ;
3303         }
3304         *cp2 = *cp1;
3305         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
3306         *cp1 = '.';
3307         /* We've now got a VMS 'path'; fall through */
3308       }
3309       dirfab.fab$b_fns = strlen(dir);
3310       dirfab.fab$l_fna = dir;
3311       if (dir[dirfab.fab$b_fns-1] == ']' ||
3312           dir[dirfab.fab$b_fns-1] == '>' ||
3313           dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3314         if (buf) retpath = buf;
3315         else if (ts) New(1314,retpath,strlen(dir)+1,char);
3316         else retpath = __pathify_retbuf;
3317         strcpy(retpath,dir);
3318         return retpath;
3319       }
3320       dirfab.fab$l_dna = ".DIR;1";
3321       dirfab.fab$b_dns = 6;
3322       dirfab.fab$l_nam = &dirnam;
3323       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3324       dirnam.nam$l_esa = esa;
3325
3326       for (cp = dir; *cp; cp++)
3327         if (islower(*cp)) { haslower = 1; break; }
3328
3329       if (!(sts = (sys$parse(&dirfab)&1))) {
3330         if (dirfab.fab$l_sts == RMS$_DIR) {
3331           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3332           sts = sys$parse(&dirfab) & 1;
3333         }
3334         if (!sts) {
3335           set_errno(EVMSERR);
3336           set_vaxc_errno(dirfab.fab$l_sts);
3337           return NULL;
3338         }
3339       }
3340       else {
3341         savnam = dirnam;
3342         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
3343           if (dirfab.fab$l_sts != RMS$_FNF) {
3344             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3345             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3346             set_errno(EVMSERR);
3347             set_vaxc_errno(dirfab.fab$l_sts);
3348             return NULL;
3349           }
3350           dirnam = savnam; /* No; just work with potential name */
3351         }
3352       }
3353       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3354         /* Yep; check version while we're at it, if it's there. */
3355         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3356         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3357           /* Something other than .DIR[;1].  Bzzt. */
3358           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3359           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3360           set_errno(ENOTDIR);
3361           set_vaxc_errno(RMS$_DIR);
3362           return NULL;
3363         }
3364       }
3365       /* OK, the type was fine.  Now pull any file name into the
3366          directory path. */
3367       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3368       else {
3369         cp1 = strrchr(esa,'>');
3370         *dirnam.nam$l_type = '>';
3371       }
3372       *cp1 = '.';
3373       *(dirnam.nam$l_type + 1) = '\0';
3374       retlen = dirnam.nam$l_type - esa + 2;
3375       if (buf) retpath = buf;
3376       else if (ts) New(1314,retpath,retlen,char);
3377       else retpath = __pathify_retbuf;
3378       strcpy(retpath,esa);
3379       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3380       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3381       /* $PARSE may have upcased filespec, so convert output to lower
3382        * case if input contained any lowercase characters. */
3383       if (haslower) __mystrtolower(retpath);
3384     }
3385
3386     return retpath;
3387 }  /* end of do_pathify_dirspec() */
3388 /*}}}*/
3389 /* External entry points */
3390 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3391 { return do_pathify_dirspec(dir,buf,0); }
3392 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3393 { return do_pathify_dirspec(dir,buf,1); }
3394
3395 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3396 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3397 {
3398   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3399   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3400   int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3401
3402   if (spec == NULL) return NULL;
3403   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3404   if (buf) rslt = buf;
3405   else if (ts) {
3406     retlen = strlen(spec);
3407     cp1 = strchr(spec,'[');
3408     if (!cp1) cp1 = strchr(spec,'<');
3409     if (cp1) {
3410       for (cp1++; *cp1; cp1++) {
3411         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
3412         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3413           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3414       }
3415     }
3416     New(1315,rslt,retlen+2+2*expand,char);
3417   }
3418   else rslt = __tounixspec_retbuf;
3419   if (strchr(spec,'/') != NULL) {
3420     strcpy(rslt,spec);
3421     return rslt;
3422   }
3423
3424   cp1 = rslt;
3425   cp2 = spec;
3426   dirend = strrchr(spec,']');
3427   if (dirend == NULL) dirend = strrchr(spec,'>');
3428   if (dirend == NULL) dirend = strchr(spec,':');
3429   if (dirend == NULL) {
3430     strcpy(rslt,spec);
3431     return rslt;
3432   }
3433   if (*cp2 != '[' && *cp2 != '<') {
3434     *(cp1++) = '/';
3435   }
3436   else {  /* the VMS spec begins with directories */
3437     cp2++;
3438     if (*cp2 == ']' || *cp2 == '>') {
3439       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3440       return rslt;
3441     }
3442     else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3443       if (getcwd(tmp,sizeof tmp,1) == NULL) {
3444         if (ts) Safefree(rslt);
3445         return NULL;
3446       }
3447       do {
3448         cp3 = tmp;
3449         while (*cp3 != ':' && *cp3) cp3++;
3450         *(cp3++) = '\0';
3451         if (strchr(cp3,']') != NULL) break;
3452       } while (vmstrnenv(tmp,tmp,0,fildev,0));
3453       if (ts && !buf &&
3454           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3455         retlen = devlen + dirlen;
3456         Renew(rslt,retlen+1+2*expand,char);
3457         cp1 = rslt;
3458       }
3459       cp3 = tmp;
3460       *(cp1++) = '/';
3461       while (*cp3) {
3462         *(cp1++) = *(cp3++);
3463         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3464       }
3465       *(cp1++) = '/';
3466     }
3467     else if ( *cp2 == '.') {
3468       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3469         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3470         cp2 += 3;
3471       }
3472       else cp2++;
3473     }
3474   }
3475   for (; cp2 <= dirend; cp2++) {
3476     if (*cp2 == ':') {
3477       *(cp1++) = '/';
3478       if (*(cp2+1) == '[') cp2++;
3479     }
3480     else if (*cp2 == ']' || *cp2 == '>') {
3481       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3482     }
3483     else if (*cp2 == '.') {
3484       *(cp1++) = '/';
3485       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3486         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3487                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3488         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3489             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3490       }
3491       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3492         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3493         cp2 += 2;
3494       }
3495     }
3496     else if (*cp2 == '-') {
3497       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3498         while (*cp2 == '-') {
3499           cp2++;
3500           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3501         }
3502         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3503           if (ts) Safefree(rslt);                        /* filespecs like */
3504           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
3505           return NULL;
3506         }
3507       }
3508       else *(cp1++) = *cp2;
3509     }
3510     else *(cp1++) = *cp2;
3511   }
3512   while (*cp2) *(cp1++) = *(cp2++);
3513   *cp1 = '\0';
3514
3515   return rslt;
3516
3517 }  /* end of do_tounixspec() */
3518 /*}}}*/
3519 /* External entry points */
3520 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3521 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3522
3523 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3524 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3525   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3526   char *rslt, *dirend;
3527   register char *cp1, *cp2;
3528   unsigned long int infront = 0, hasdir = 1;
3529
3530   if (path == NULL) return NULL;
3531   if (buf) rslt = buf;
3532   else if (ts) New(1316,rslt,strlen(path)+9,char);
3533   else rslt = __tovmsspec_retbuf;
3534   if (strpbrk(path,"]:>") ||
3535       (dirend = strrchr(path,'/')) == NULL) {
3536     if (path[0] == '.') {
3537       if (path[1] == '\0') strcpy(rslt,"[]");
3538       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3539       else strcpy(rslt,path); /* probably garbage */
3540     }
3541     else strcpy(rslt,path);
3542     return rslt;
3543   }
3544   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
3545     if (!*(dirend+2)) dirend +=2;
3546     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3547     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3548   }
3549   cp1 = rslt;
3550   cp2 = path;
3551   if (*cp2 == '/') {
3552     char trndev[NAM$C_MAXRSS+1];
3553     int islnm, rooted;
3554     STRLEN trnend;
3555
3556     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
3557     if (!*(cp2+1)) {
3558       if (!buf & ts) Renew(rslt,18,char);
3559       strcpy(rslt,"sys$disk:[000000]");
3560       return rslt;
3561     }
3562     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3563     *cp1 = '\0';
3564     islnm =  my_trnlnm(rslt,trndev,0);
3565     trnend = islnm ? strlen(trndev) - 1 : 0;
3566     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3567     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3568     /* If the first element of the path is a logical name, determine
3569      * whether it has to be translated so we can add more directories. */
3570     if (!islnm || rooted) {
3571       *(cp1++) = ':';
3572       *(cp1++) = '[';
3573       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3574       else cp2++;
3575     }
3576     else {
3577       if (cp2 != dirend) {
3578         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3579         strcpy(rslt,trndev);
3580         cp1 = rslt + trnend;
3581         *(cp1++) = '.';
3582         cp2++;
3583       }
3584       else {
3585         *(cp1++) = ':';
3586         hasdir = 0;
3587       }
3588     }
3589   }
3590   else {
3591     *(cp1++) = '[';
3592     if (*cp2 == '.') {
3593       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3594         cp2 += 2;         /* skip over "./" - it's redundant */
3595         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
3596       }
3597       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3598         *(cp1++) = '-';                                 /* "../" --> "-" */
3599         cp2 += 3;
3600       }
3601       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3602                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3603         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3604         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3605         cp2 += 4;
3606       }
3607       if (cp2 > dirend) cp2 = dirend;
3608     }
3609     else *(cp1++) = '.';
3610   }
3611   for (; cp2 < dirend; cp2++) {
3612     if (*cp2 == '/') {
3613       if (*(cp2-1) == '/') continue;
3614       if (*(cp1-1) != '.') *(cp1++) = '.';
3615       infront = 0;
3616     }
3617     else if (!infront && *cp2 == '.') {
3618       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3619       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
3620       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3621         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3622         else if (*(cp1-2) == '[') *(cp1-1) = '-';
3623         else {  /* back up over previous directory name */
3624           cp1--;
3625           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3626           if (*(cp1-1) == '[') {
3627             memcpy(cp1,"000000.",7);
3628             cp1 += 7;
3629           }
3630         }
3631         cp2 += 2;
3632         if (cp2 == dirend) break;
3633       }
3634       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3635                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3636         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3637         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3638         if (!*(cp2+3)) {
3639           *(cp1++) = '.';  /* Simulate trailing '/' */
3640           cp2 += 2;  /* for loop will incr this to == dirend */
3641         }
3642         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
3643       }
3644       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
3645     }
3646     else {
3647       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
3648       if (*cp2 == '.')      *(cp1++) = '_';
3649       else                  *(cp1++) =  *cp2;
3650       infront = 1;
3651     }
3652   }
3653   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3654   if (hasdir) *(cp1++) = ']';
3655   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
3656   while (*cp2) *(cp1++) = *(cp2++);
3657   *cp1 = '\0';
3658
3659   return rslt;
3660
3661 }  /* end of do_tovmsspec() */
3662 /*}}}*/
3663 /* External entry points */
3664 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3665 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3666
3667 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3668 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3669   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3670   int vmslen;
3671   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3672
3673   if (path == NULL) return NULL;
3674   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3675   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3676   if (buf) return buf;
3677   else if (ts) {
3678     vmslen = strlen(vmsified);
3679     New(1317,cp,vmslen+1,char);
3680     memcpy(cp,vmsified,vmslen);
3681     cp[vmslen] = '\0';
3682     return cp;
3683   }
3684   else {
3685     strcpy(__tovmspath_retbuf,vmsified);
3686     return __tovmspath_retbuf;
3687   }
3688
3689 }  /* end of do_tovmspath() */
3690 /*}}}*/
3691 /* External entry points */
3692 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3693 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3694
3695
3696 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3697 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3698   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3699   int unixlen;
3700   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3701
3702   if (path == NULL) return NULL;
3703   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3704   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3705   if (buf) return buf;
3706   else if (ts) {
3707     unixlen = strlen(unixified);
3708     New(1317,cp,unixlen+1,char);
3709     memcpy(cp,unixified,unixlen);
3710     cp[unixlen] = '\0';
3711     return cp;
3712   }
3713   else {
3714     strcpy(__tounixpath_retbuf,unixified);
3715     return __tounixpath_retbuf;
3716   }
3717
3718 }  /* end of do_tounixpath() */
3719 /*}}}*/
3720 /* External entry points */
3721 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3722 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3723
3724 /*
3725  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
3726  *
3727  *****************************************************************************
3728  *                                                                           *
3729  *  Copyright (C) 1989-1994 by                                               *
3730  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
3731  *                                                                           *
3732  *  Permission is hereby  granted for the reproduction of this software,     *
3733  *  on condition that this copyright notice is included in the reproduction, *
3734  *  and that such reproduction is not for purposes of profit or material     *
3735  *  gain.                                                                    *
3736  *                                                                           *
3737  *  27-Aug-1994 Modified for inclusion in perl5                              *
3738  *              by Charles Bailey  bailey@newman.upenn.edu                   *
3739  *****************************************************************************
3740  */
3741
3742 /*
3743  * getredirection() is intended to aid in porting C programs
3744  * to VMS (Vax-11 C).  The native VMS environment does not support
3745  * '>' and '<' I/O redirection, or command line wild card expansion,
3746  * or a command line pipe mechanism using the '|' AND background
3747  * command execution '&'.  All of these capabilities are provided to any
3748  * C program which calls this procedure as the first thing in the
3749  * main program.
3750  * The piping mechanism will probably work with almost any 'filter' type
3751  * of program.  With suitable modification, it may useful for other
3752  * portability problems as well.
3753  *
3754  * Author:  Mark Pizzolato      mark@infocomm.com
3755  */
3756 struct list_item
3757     {
3758     struct list_item *next;
3759     char *value;
3760     };
3761
3762 static void add_item(struct list_item **head,
3763                      struct list_item **tail,
3764                      char *value,
3765                      int *count);
3766
3767 static void mp_expand_wild_cards(pTHX_ char *item,
3768                                 struct list_item **head,
3769                                 struct list_item **tail,
3770                                 int *count);
3771
3772 static int background_process(int argc, char **argv);
3773
3774 static void pipe_and_fork(pTHX_ char **cmargv);
3775
3776 /*{{{ void getredirection(int *ac, char ***av)*/
3777 static void
3778 mp_getredirection(pTHX_ int *ac, char ***av)
3779 /*
3780  * Process vms redirection arg's.  Exit if any error is seen.
3781  * If getredirection() processes an argument, it is erased
3782  * from the vector.  getredirection() returns a new argc and argv value.
3783  * In the event that a background command is requested (by a trailing "&"),
3784  * this routine creates a background subprocess, and simply exits the program.
3785  *
3786  * Warning: do not try to simplify the code for vms.  The code
3787  * presupposes that getredirection() is called before any data is
3788  * read from stdin or written to stdout.
3789  *
3790  * Normal usage is as follows:
3791  *
3792  *      main(argc, argv)
3793  *      int             argc;
3794  *      char            *argv[];
3795  *      {
3796  *              getredirection(&argc, &argv);
3797  *      }
3798  */
3799 {
3800     int                 argc = *ac;     /* Argument Count         */
3801     char                **argv = *av;   /* Argument Vector        */
3802     char                *ap;            /* Argument pointer       */
3803     int                 j;              /* argv[] index           */
3804     int                 item_count = 0; /* Count of Items in List */
3805     struct list_item    *list_head = 0; /* First Item in List       */
3806     struct list_item    *list_tail;     /* Last Item in List        */
3807     char                *in = NULL;     /* Input File Name          */
3808     char                *out = NULL;    /* Output File Name         */
3809     char                *outmode = "w"; /* Mode to Open Output File */
3810     char                *err = NULL;    /* Error File Name          */
3811     char                *errmode = "w"; /* Mode to Open Error File  */
3812     int                 cmargc = 0;     /* Piped Command Arg Count  */
3813     char                **cmargv = NULL;/* Piped Command Arg Vector */
3814
3815     /*
3816      * First handle the case where the last thing on the line ends with
3817      * a '&'.  This indicates the desire for the command to be run in a
3818      * subprocess, so we satisfy that desire.
3819      */
3820     ap = argv[argc-1];
3821     if (0 == strcmp("&", ap))
3822         exit(background_process(--argc, argv));
3823     if (*ap && '&' == ap[strlen(ap)-1])
3824         {
3825         ap[strlen(ap)-1] = '\0';
3826         exit(background_process(argc, argv));
3827         }
3828     /*
3829      * Now we handle the general redirection cases that involve '>', '>>',
3830      * '<', and pipes '|'.
3831      */
3832     for (j = 0; j < argc; ++j)
3833         {
3834         if (0 == strcmp("<", argv[j]))
3835             {
3836             if (j+1 >= argc)
3837                 {
3838                 fprintf(stderr,"No input file after < on command line");
3839                 exit(LIB$_WRONUMARG);
3840                 }
3841             in = argv[++j];
3842             continue;
3843             }
3844         if ('<' == *(ap = argv[j]))
3845             {
3846             in = 1 + ap;
3847             continue;
3848             }
3849         if (0 == strcmp(">", ap))
3850             {
3851             if (j+1 >= argc)
3852                 {
3853                 fprintf(stderr,"No output file after > on command line");
3854                 exit(LIB$_WRONUMARG);
3855                 }
3856             out = argv[++j];
3857             continue;
3858             }
3859         if ('>' == *ap)
3860             {
3861             if ('>' == ap[1])
3862                 {
3863                 outmode = "a";
3864                 if ('\0' == ap[2])
3865                     out = argv[++j];
3866                 else
3867                     out = 2 + ap;
3868                 }
3869             else
3870                 out = 1 + ap;
3871             if (j >= argc)
3872                 {
3873                 fprintf(stderr,"No output file after > or >> on command line");
3874                 exit(LIB$_WRONUMARG);
3875                 }
3876             continue;
3877             }
3878         if (('2' == *ap) && ('>' == ap[1]))
3879             {
3880             if ('>' == ap[2])
3881                 {
3882                 errmode = "a";
3883                 if ('\0' == ap[3])
3884                     err = argv[++j];
3885                 else
3886                     err = 3 + ap;
3887                 }
3888             else
3889                 if ('\0' == ap[2])
3890                     err = argv[++j];
3891                 else
3892                     err = 2 + ap;
3893             if (j >= argc)
3894                 {
3895                 fprintf(stderr,"No output file after 2> or 2>> on command line");
3896                 exit(LIB$_WRONUMARG);
3897                 }
3898             continue;
3899             }
3900         if (0 == strcmp("|", argv[j]))
3901             {
3902             if (j+1 >= argc)
3903                 {
3904                 fprintf(stderr,"No command into which to pipe on command line");
3905                 exit(LIB$_WRONUMARG);
3906                 }
3907             cmargc = argc-(j+1);
3908             cmargv = &argv[j+1];
3909             argc = j;
3910             continue;
3911             }
3912         if ('|' == *(ap = argv[j]))
3913             {
3914             ++argv[j];
3915             cmargc = argc-j;
3916             cmargv = &argv[j];
3917             argc = j;
3918             continue;
3919             }
3920         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3921         }
3922     /*
3923      * Allocate and fill in the new argument vector, Some Unix's terminate
3924      * the list with an extra null pointer.
3925      */
3926     New(1302, argv, item_count+1, char *);
3927     *av = argv;
3928     for (j = 0; j < item_count; ++j, list_head = list_head->next)
3929         argv[j] = list_head->value;
3930     *ac = item_count;
3931     if (cmargv != NULL)
3932         {
3933         if (out != NULL)
3934             {
3935             fprintf(stderr,"'|' and '>' may not both be specified on command line");
3936             exit(LIB$_INVARGORD);
3937             }
3938         pipe_and_fork(aTHX_ cmargv);
3939         }
3940
3941     /* Check for input from a pipe (mailbox) */
3942
3943     if (in == NULL && 1 == isapipe(0))
3944         {
3945         char mbxname[L_tmpnam];
3946         long int bufsize;
3947         long int dvi_item = DVI$_DEVBUFSIZ;
3948         $DESCRIPTOR(mbxnam, "");
3949         $DESCRIPTOR(mbxdevnam, "");
3950
3951         /* Input from a pipe, reopen it in binary mode to disable       */
3952         /* carriage control processing.                                 */
3953
3954         fgetname(stdin, mbxname);
3955         mbxnam.dsc$a_pointer = mbxname;
3956         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3957         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3958         mbxdevnam.dsc$a_pointer = mbxname;
3959         mbxdevnam.dsc$w_length = sizeof(mbxname);
3960         dvi_item = DVI$_DEVNAM;
3961         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3962         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3963         set_errno(0);
3964         set_vaxc_errno(1);
3965         freopen(mbxname, "rb", stdin);
3966         if (errno != 0)
3967             {
3968             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3969             exit(vaxc$errno);
3970             }
3971         }
3972     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3973         {
3974         fprintf(stderr,"Can't open input file %s as stdin",in);
3975         exit(vaxc$errno);
3976         }
3977     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3978         {
3979         fprintf(stderr,"Can't open output file %s as stdout",out);
3980         exit(vaxc$errno);
3981         }
3982         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
3983
3984     if (err != NULL) {
3985         if (strcmp(err,"&1") == 0) {
3986             dup2(fileno(stdout), fileno(stderr));
3987             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
3988         } else {
3989         FILE *tmperr;
3990         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3991             {
3992             fprintf(stderr,"Can't open error file %s as stderr",err);
3993             exit(vaxc$errno);
3994             }
3995             fclose(tmperr);
3996            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
3997                 {
3998                 exit(vaxc$errno);
3999                 }
4000             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4001         }
4002         }
4003 #ifdef ARGPROC_DEBUG
4004     PerlIO_printf(Perl_debug_log, "Arglist:\n");
4005     for (j = 0; j < *ac;  ++j)
4006         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4007 #endif
4008    /* Clear errors we may have hit expanding wildcards, so they don't
4009       show up in Perl's $! later */
4010    set_errno(0); set_vaxc_errno(1);
4011 }  /* end of getredirection() */
4012 /*}}}*/
4013
4014 static void add_item(struct list_item **head,
4015                      struct list_item **tail,
4016                      char *value,
4017                      int *count)
4018 {
4019     if (*head == 0)
4020         {
4021         New(1303,*head,1,struct list_item);
4022         *tail = *head;
4023         }
4024     else {
4025         New(1304,(*tail)->next,1,struct list_item);
4026         *tail = (*tail)->next;
4027         }
4028     (*tail)->value = value;
4029     ++(*count);
4030 }
4031
4032 static void mp_expand_wild_cards(pTHX_ char *item,
4033                               struct list_item **head,
4034                               struct list_item **tail,
4035                               int *count)
4036 {
4037 int expcount = 0;
4038 unsigned long int context = 0;
4039 int isunix = 0;
4040 char *had_version;
4041 char *had_device;
4042 int had_directory;
4043 char *devdir,*cp;
4044 char vmsspec[NAM$C_MAXRSS+1];
4045 $DESCRIPTOR(filespec, "");
4046 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4047 $DESCRIPTOR(resultspec, "");
4048 unsigned long int zero = 0, sts;
4049
4050     for (cp = item; *cp; cp++) {
4051         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4052         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4053     }
4054     if (!*cp || isspace(*cp))
4055         {
4056         add_item(head, tail, item, count);
4057         return;
4058         }
4059     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4060     resultspec.dsc$b_class = DSC$K_CLASS_D;
4061     resultspec.dsc$a_pointer = NULL;
4062     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4063       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4064     if (!isunix || !filespec.dsc$a_pointer)
4065       filespec.dsc$a_pointer = item;
4066     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4067     /*
4068      * Only return version specs, if the caller specified a version
4069      */
4070     had_version = strchr(item, ';');
4071     /*
4072      * Only return device and directory specs, if the caller specifed either.
4073      */
4074     had_device = strchr(item, ':');
4075     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4076
4077     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4078                                   &defaultspec, 0, 0, &zero))))
4079         {
4080         char *string;
4081         char *c;
4082
4083         New(1305,string,resultspec.dsc$w_length+1,char);
4084         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4085         string[resultspec.dsc$w_length] = '\0';
4086         if (NULL == had_version)
4087             *((char *)strrchr(string, ';')) = '\0';
4088         if ((!had_directory) && (had_device == NULL))
4089             {
4090             if (NULL == (devdir = strrchr(string, ']')))
4091                 devdir = strrchr(string, '>');
4092             strcpy(string, devdir + 1);
4093             }
4094         /*
4095          * Be consistent with what the C RTL has already done to the rest of
4096          * the argv items and lowercase all of these names.
4097          */
4098         for (c = string; *c; ++c)
4099             if (isupper(*c))
4100                 *c = tolower(*c);
4101         if (isunix) trim_unixpath(string,item,1);
4102         add_item(head, tail, string, count);
4103         ++expcount;
4104         }
4105     if (sts != RMS$_NMF)
4106         {
4107         set_vaxc_errno(sts);
4108         switch (sts)
4109             {
4110             case RMS$_FNF: case RMS$_DNF:
4111                 set_errno(ENOENT); break;
4112             case RMS$_DIR:
4113                 set_errno(ENOTDIR); break;
4114             case RMS$_DEV:
4115                 set_errno(ENODEV); break;
4116             case RMS$_FNM: case RMS$_SYN:
4117                 set_errno(EINVAL); break;
4118             case RMS$_PRV:
4119                 set_errno(EACCES); break;
4120             default:
4121                 _ckvmssts_noperl(sts);
4122             }
4123         }
4124     if (expcount == 0)
4125         add_item(head, tail, item, count);
4126     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4127     _ckvmssts_noperl(lib$find_file_end(&context));
4128 }
4129
4130 static int child_st[2];/* Event Flag set when child process completes   */
4131
4132 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
4133
4134 static unsigned long int exit_handler(int *status)
4135 {
4136 short iosb[4];
4137
4138     if (0 == child_st[0])
4139         {
4140 #ifdef ARGPROC_DEBUG
4141         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4142 #endif
4143         fflush(stdout);     /* Have to flush pipe for binary data to    */
4144                             /* terminate properly -- <tp@mccall.com>    */
4145         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4146         sys$dassgn(child_chan);
4147         fclose(stdout);
4148         sys$synch(0, child_st);
4149         }
4150     return(1);
4151 }
4152
4153 static void sig_child(int chan)
4154 {
4155 #ifdef ARGPROC_DEBUG
4156     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4157 #endif
4158     if (child_st[0] == 0)
4159         child_st[0] = 1;
4160 }
4161
4162 static struct exit_control_block exit_block =
4163     {
4164     0,
4165     exit_handler,
4166     1,
4167     &exit_block.exit_status,
4168     0
4169     };
4170
4171 static void
4172 pipe_and_fork(pTHX_ char **cmargv)
4173 {
4174     PerlIO *fp;
4175     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4176     int sts, j, l, ismcr, quote, tquote = 0;
4177
4178     sts = setup_cmddsc(cmargv[0],0,&quote);
4179
4180     j = l = 0;
4181     p = subcmd;
4182     q = cmargv[0];
4183     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
4184               && toupper(*(q+2)) == 'R' && !*(q+3);
4185
4186     while (q && l < MAX_DCL_LINE_LENGTH) {
4187         if (!*q) {
4188             if (j > 0 && quote) {
4189                 *p++ = '"';
4190                 l++;
4191             }
4192             q = cmargv[++j];
4193             if (q) {
4194                 if (ismcr && j > 1) quote = 1;
4195                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
4196                 *p++ = ' ';
4197                 l++;
4198                 if (quote || tquote) {
4199                     *p++ = '"';
4200                     l++;
4201                 }
4202         }
4203         } else {
4204             if ((quote||tquote) && *q == '"') {
4205                 *p++ = '"';
4206                 l++;
4207         }
4208             *p++ = *q++;
4209             l++;
4210         }
4211     }
4212     *p = '\0';
4213
4214     fp = safe_popen(subcmd,"wbF",&sts);
4215     if (fp == Nullfp) {
4216         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4217         }
4218 }
4219
4220 static int background_process(int argc, char **argv)
4221 {
4222 char command[2048] = "$";
4223 $DESCRIPTOR(value, "");
4224 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4225 static $DESCRIPTOR(null, "NLA0:");
4226 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4227 char pidstring[80];
4228 $DESCRIPTOR(pidstr, "");
4229 int pid;
4230 unsigned long int flags = 17, one = 1, retsts;
4231
4232     strcat(command, argv[0]);
4233     while (--argc)
4234         {
4235         strcat(command, " \"");
4236         strcat(command, *(++argv));
4237         strcat(command, "\"");
4238         }
4239     value.dsc$a_pointer = command;
4240     value.dsc$w_length = strlen(value.dsc$a_pointer);
4241     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4242     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4243     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4244         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4245     }
4246     else {
4247         _ckvmssts_noperl(retsts);
4248     }
4249 #ifdef ARGPROC_DEBUG
4250     PerlIO_printf(Perl_debug_log, "%s\n", command);
4251 #endif
4252     sprintf(pidstring, "%08X", pid);
4253     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4254     pidstr.dsc$a_pointer = pidstring;
4255     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4256     lib$set_symbol(&pidsymbol, &pidstr);
4257     return(SS$_NORMAL);
4258 }
4259 /*}}}*/
4260 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4261
4262
4263 /* OS-specific initialization at image activation (not thread startup) */
4264 /* Older VAXC header files lack these constants */
4265 #ifndef JPI$_RIGHTS_SIZE
4266 #  define JPI$_RIGHTS_SIZE 817
4267 #endif
4268 #ifndef KGB$M_SUBSYSTEM
4269 #  define KGB$M_SUBSYSTEM 0x8
4270 #endif
4271
4272 /*{{{void vms_image_init(int *, char ***)*/
4273 void
4274 vms_image_init(int *argcp, char ***argvp)
4275 {
4276   char eqv[LNM$C_NAMLENGTH+1] = "";
4277   unsigned int len, tabct = 8, tabidx = 0;
4278   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4279   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4280   unsigned short int dummy, rlen;
4281   struct dsc$descriptor_s **tabvec;
4282 #if defined(PERL_IMPLICIT_CONTEXT)
4283   pTHX = NULL;
4284 #endif
4285   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
4286                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
4287                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4288                                  {          0,                0,    0,      0} };
4289
4290   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4291   _ckvmssts_noperl(iosb[0]);
4292   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4293     if (iprv[i]) {           /* Running image installed with privs? */
4294       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
4295       will_taint = TRUE;
4296       break;
4297     }
4298   }
4299   /* Rights identifiers might trigger tainting as well. */
4300   if (!will_taint && (rlen || rsz)) {
4301     while (rlen < rsz) {
4302       /* We didn't get all the identifiers on the first pass.  Allocate a
4303        * buffer much larger than $GETJPI wants (rsz is size in bytes that
4304        * were needed to hold all identifiers at time of last call; we'll
4305        * allocate that many unsigned long ints), and go back and get 'em.
4306        * If it gave us less than it wanted to despite ample buffer space,
4307        * something's broken.  Is your system missing a system identifier?
4308        */
4309       if (rsz <= jpilist[1].buflen) {
4310          /* Perl_croak accvios when used this early in startup. */
4311          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4312                          rsz, (unsigned long) jpilist[1].buflen,
4313                          "Check your rights database for corruption.\n");
4314          exit(SS$_ABORT);
4315       }
4316       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4317       jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4318       jpilist[1].buflen = rsz * sizeof(unsigned long int);
4319       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4320       _ckvmssts_noperl(iosb[0]);
4321     }
4322     mask = jpilist[1].bufadr;
4323     /* Check attribute flags for each identifier (2nd longword); protected
4324      * subsystem identifiers trigger tainting.
4325      */
4326     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4327       if (mask[i] & KGB$M_SUBSYSTEM) {
4328         will_taint = TRUE;
4329         break;
4330       }
4331     }
4332     if (mask != rlst) Safefree(mask);
4333   }
4334   /* We need to use this hack to tell Perl it should run with tainting,
4335    * since its tainting flag may be part of the PL_curinterp struct, which
4336    * hasn't been allocated when vms_image_init() is called.
4337    */
4338   if (will_taint) {
4339     char ***newap;
4340     New(1320,newap,*argcp+2,char **);
4341     newap[0] = argvp[0];
4342     *newap[1] = "-T";
4343     Copy(argvp[1],newap[2],*argcp-1,char **);
4344     /* We orphan the old argv, since we don't know where it's come from,
4345      * so we don't know how to free it.
4346      */
4347     *argcp++; argvp = newap;
4348   }
4349   else {  /* Did user explicitly request tainting? */
4350     int i;
4351     char *cp, **av = *argvp;
4352     for (i = 1; i < *argcp; i++) {
4353       if (*av[i] != '-') break;
4354       for (cp = av[i]+1; *cp; cp++) {
4355         if (*cp == 'T') { will_taint = 1; break; }
4356         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4357                   strchr("DFIiMmx",*cp)) break;
4358       }
4359       if (will_taint) break;
4360     }
4361   }
4362
4363   for (tabidx = 0;
4364        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4365        tabidx++) {
4366     if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4367     else if (tabidx >= tabct) {
4368       tabct += 8;
4369       Renew(tabvec,tabct,struct dsc$descriptor_s *);
4370     }
4371     New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4372     tabvec[tabidx]->dsc$w_length  = 0;
4373     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
4374     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
4375     tabvec[tabidx]->dsc$a_pointer = NULL;
4376     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4377   }
4378   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4379
4380   getredirection(argcp,argvp);
4381 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4382   {
4383 # include <reentrancy.h>
4384   (void) decc$set_reentrancy(C$C_MULTITHREAD);
4385   }
4386 #endif
4387   return;
4388 }
4389 /*}}}*/
4390
4391
4392 /* trim_unixpath()
4393  * Trim Unix-style prefix off filespec, so it looks like what a shell
4394  * glob expansion would return (i.e. from specified prefix on, not
4395  * full path).  Note that returned filespec is Unix-style, regardless
4396  * of whether input filespec was VMS-style or Unix-style.
4397  *
4398  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4399  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
4400  * vector of options; at present, only bit 0 is used, and if set tells
4401  * trim unixpath to try the current default directory as a prefix when
4402  * presented with a possibly ambiguous ... wildcard.
4403  *
4404  * Returns !=0 on success, with trimmed filespec replacing contents of
4405  * fspec, and 0 on failure, with contents of fpsec unchanged.
4406  */
4407 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4408 int
4409 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4410 {
4411   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4412        *template, *base, *end, *cp1, *cp2;
4413   register int tmplen, reslen = 0, dirs = 0;
4414
4415   if (!wildspec || !fspec) return 0;
4416   if (strpbrk(wildspec,"]>:") != NULL) {
4417     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4418     else template = unixwild;
4419   }
4420   else template = wildspec;
4421   if (strpbrk(fspec,"]>:") != NULL) {
4422     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4423     else base = unixified;
4424     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4425      * check to see that final result fits into (isn't longer than) fspec */
4426     reslen = strlen(fspec);
4427   }
4428   else base = fspec;
4429
4430   /* No prefix or absolute path on wildcard, so nothing to remove */
4431   if (!*template || *template == '/') {
4432     if (base == fspec) return 1;
4433     tmplen = strlen(unixified);
4434     if (tmplen > reslen) return 0;  /* not enough space */
4435     /* Copy unixified resultant, including trailing NUL */
4436     memmove(fspec,unixified,tmplen+1);
4437     return 1;
4438   }
4439
4440   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
4441   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4442     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4443     for (cp1 = end ;cp1 >= base; cp1--)
4444       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4445         { cp1++; break; }
4446     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4447     return 1;
4448   }
4449   else {
4450     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4451     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4452     int ells = 1, totells, segdirs, match;
4453     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4454                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4455
4456     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4457     totells = ells;
4458     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4459     if (ellipsis == template && opts & 1) {
4460       /* Template begins with an ellipsis.  Since we can't tell how many
4461        * directory names at the front of the resultant to keep for an
4462        * arbitrary starting point, we arbitrarily choose the current
4463        * default directory as a starting point.  If it's there as a prefix,
4464        * clip it off.  If not, fall through and act as if the leading
4465        * ellipsis weren't there (i.e. return shortest possible path that
4466        * could match template).
4467        */
4468       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4469       for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4470         if (_tolower(*cp1) != _tolower(*cp2)) break;
4471       segdirs = dirs - totells;  /* Min # of dirs we must have left */
4472       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4473       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4474         memcpy(fspec,cp2+1,end - cp2);
4475         return 1;
4476       }
4477     }
4478     /* First off, back up over constant elements at end of path */
4479     if (dirs) {
4480       for (front = end ; front >= base; front--)
4481          if (*front == '/' && !dirs--) { front++; break; }
4482     }
4483     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4484          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
4485     if (cp1 != '\0') return 0;  /* Path too long. */
4486     lcend = cp2;
4487     *cp2 = '\0';  /* Pick up with memcpy later */
4488     lcfront = lcres + (front - base);
4489     /* Now skip over each ellipsis and try to match the path in front of it. */
4490     while (ells--) {
4491       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4492         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
4493             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
4494       if (cp1 < template) break; /* template started with an ellipsis */
4495       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4496         ellipsis = cp1; continue;
4497       }
4498       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4499       nextell = cp1;
4500       for (segdirs = 0, cp2 = tpl;
4501            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4502            cp1++, cp2++) {
4503          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4504          else *cp2 = _tolower(*cp1);  /* else lowercase for match */
4505          if (*cp2 == '/') segdirs++;
4506       }
4507       if (cp1 != ellipsis - 1) return 0; /* Path too long */
4508       /* Back up at least as many dirs as in template before matching */
4509       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4510         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4511       for (match = 0; cp1 > lcres;) {
4512         resdsc.dsc$a_pointer = cp1;
4513         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4514           match++;
4515           if (match == 1) lcfront = cp1;
4516         }
4517         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4518       }
4519       if (!match) return 0;  /* Can't find prefix ??? */
4520       if (match > 1 && opts & 1) {
4521         /* This ... wildcard could cover more than one set of dirs (i.e.
4522          * a set of similar dir names is repeated).  If the template
4523          * contains more than 1 ..., upstream elements could resolve the
4524          * ambiguity, but it's not worth a full backtracking setup here.
4525          * As a quick heuristic, clip off the current default directory
4526          * if it's present to find the trimmed spec, else use the
4527          * shortest string that this ... could cover.
4528          */
4529         char def[NAM$C_MAXRSS+1], *st;
4530
4531         if (getcwd(def, sizeof def,0) == NULL) return 0;
4532         for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4533           if (_tolower(*cp1) != _tolower(*cp2)) break;
4534         segdirs = dirs - totells;  /* Min # of dirs we must have left */
4535         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4536         if (*cp1 == '\0' && *cp2 == '/') {
4537           memcpy(fspec,cp2+1,end - cp2);
4538           return 1;
4539         }
4540         /* Nope -- stick with lcfront from above and keep going. */
4541       }
4542     }
4543     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4544     return 1;
4545     ellipsis = nextell;
4546   }
4547
4548 }  /* end of trim_unixpath() */
4549 /*}}}*/
4550
4551
4552 /*
4553  *  VMS readdir() routines.
4554  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4555  *
4556  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
4557  *  Minor modifications to original routines.
4558  */
4559
4560     /* Number of elements in vms_versions array */
4561 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
4562
4563 /*
4564  *  Open a directory, return a handle for later use.
4565  */
4566 /*{{{ DIR *opendir(char*name) */
4567 DIR *
4568 Perl_opendir(pTHX_ char *name)
4569 {
4570     DIR *dd;
4571     char dir[NAM$C_MAXRSS+1];
4572     Stat_t sb;
4573
4574     if (do_tovmspath(name,dir,0) == NULL) {
4575       return NULL;
4576     }
4577     if (flex_stat(dir,&sb) == -1) return NULL;
4578     if (!S_ISDIR(sb.st_mode)) {
4579       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
4580       return NULL;
4581     }
4582     if (!cando_by_name(S_IRUSR,0,dir)) {
4583       set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4584       return NULL;
4585     }
4586     /* Get memory for the handle, and the pattern. */
4587     New(1306,dd,1,DIR);
4588     New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4589
4590     /* Fill in the fields; mainly playing with the descriptor. */
4591     (void)sprintf(dd->pattern, "%s*.*",dir);
4592     dd->context = 0;
4593     dd->count = 0;
4594     dd->vms_wantversions = 0;
4595     dd->pat.dsc$a_pointer = dd->pattern;
4596     dd->pat.dsc$w_length = strlen(dd->pattern);
4597     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4598     dd->pat.dsc$b_class = DSC$K_CLASS_S;
4599
4600     return dd;
4601 }  /* end of opendir() */
4602 /*}}}*/
4603
4604 /*
4605  *  Set the flag to indicate we want versions or not.
4606  */
4607 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4608 void
4609 vmsreaddirversions(DIR *dd, int flag)
4610 {
4611     dd->vms_wantversions = flag;
4612 }
4613 /*}}}*/
4614
4615 /*
4616  *  Free up an opened directory.
4617  */
4618 /*{{{ void closedir(DIR *dd)*/
4619 void
4620 closedir(DIR *dd)
4621 {
4622     (void)lib$find_file_end(&dd->context);
4623     Safefree(dd->pattern);
4624     Safefree((char *)dd);
4625 }
4626 /*}}}*/
4627
4628 /*
4629  *  Collect all the version numbers for the current file.
4630  */
4631 static void
4632 collectversions(pTHX_ DIR *dd)
4633 {
4634     struct dsc$descriptor_s     pat;
4635     struct dsc$descriptor_s     res;
4636     struct dirent *e;
4637     char *p, *text, buff[sizeof dd->entry.d_name];
4638     int i;
4639     unsigned long context, tmpsts;
4640
4641     /* Convenient shorthand. */
4642     e = &dd->entry;
4643
4644     /* Add the version wildcard, ignoring the "*.*" put on before */
4645     i = strlen(dd->pattern);
4646     New(1308,text,i + e->d_namlen + 3,char);
4647     (void)strcpy(text, dd->pattern);
4648     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4649
4650     /* Set up the pattern descriptor. */
4651     pat.dsc$a_pointer = text;
4652     pat.dsc$w_length = i + e->d_namlen - 1;
4653     pat.dsc$b_dtype = DSC$K_DTYPE_T;
4654     pat.dsc$b_class = DSC$K_CLASS_S;
4655
4656     /* Set up result descriptor. */
4657     res.dsc$a_pointer = buff;
4658     res.dsc$w_length = sizeof buff - 2;
4659     res.dsc$b_dtype = DSC$K_DTYPE_T;
4660     res.dsc$b_class = DSC$K_CLASS_S;
4661
4662     /* Read files, collecting versions. */
4663     for (context = 0, e->vms_verscount = 0;
4664          e->vms_verscount < VERSIZE(e);
4665          e->vms_verscount++) {
4666         tmpsts = lib$find_file(&pat, &res, &context);
4667         if (tmpsts == RMS$_NMF || context == 0) break;
4668         _ckvmssts(tmpsts);
4669         buff[sizeof buff - 1] = '\0';
4670         if ((p = strchr(buff, ';')))
4671             e->vms_versions[e->vms_verscount] = atoi(p + 1);
4672         else
4673             e->vms_versions[e->vms_verscount] = -1;
4674     }
4675
4676     _ckvmssts(lib$find_file_end(&context));
4677     Safefree(text);
4678
4679 }  /* end of collectversions() */
4680
4681 /*
4682  *  Read the next entry from the directory.
4683  */
4684 /*{{{ struct dirent *readdir(DIR *dd)*/
4685 struct dirent *
4686 Perl_readdir(pTHX_ DIR *dd)
4687 {
4688     struct dsc$descriptor_s     res;
4689     char *p, buff[sizeof dd->entry.d_name];
4690     unsigned long int tmpsts;
4691
4692     /* Set up result descriptor, and get next file. */
4693     res.dsc$a_pointer = buff;
4694     res.dsc$w_length = sizeof buff - 2;
4695     res.dsc$b_dtype = DSC$K_DTYPE_T;
4696     res.dsc$b_class = DSC$K_CLASS_S;
4697     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4698     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
4699     if (!(tmpsts & 1)) {
4700       set_vaxc_errno(tmpsts);
4701       switch (tmpsts) {
4702         case RMS$_PRV:
4703           set_errno(EACCES); break;
4704         case RMS$_DEV:
4705           set_errno(ENODEV); break;
4706         case RMS$_DIR:
4707           set_errno(ENOTDIR); break;
4708         case RMS$_FNF: case RMS$_DNF:
4709           set_errno(ENOENT); break;
4710         default:
4711           set_errno(EVMSERR);
4712       }
4713       return NULL;
4714     }
4715     dd->count++;
4716     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4717     buff[sizeof buff - 1] = '\0';
4718     for (p = buff; *p; p++) *p = _tolower(*p);
4719     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
4720     *p = '\0';
4721
4722     /* Skip any directory component and just copy the name. */
4723     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4724     else (void)strcpy(dd->entry.d_name, buff);
4725
4726     /* Clobber the version. */
4727     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4728
4729     dd->entry.d_namlen = strlen(dd->entry.d_name);
4730     dd->entry.vms_verscount = 0;
4731     if (dd->vms_wantversions) collectversions(aTHX_ dd);
4732     return &dd->entry;
4733
4734 }  /* end of readdir() */
4735 /*}}}*/
4736
4737 /*
4738  *  Return something that can be used in a seekdir later.
4739  */
4740 /*{{{ long telldir(DIR *dd)*/
4741 long
4742 telldir(DIR *dd)
4743 {
4744     return dd->count;
4745 }
4746 /*}}}*/
4747
4748 /*
4749  *  Return to a spot where we used to be.  Brute force.
4750  */
4751 /*{{{ void seekdir(DIR *dd,long count)*/
4752 void
4753 Perl_seekdir(pTHX_ DIR *dd, long count)
4754 {
4755     int vms_wantversions;
4756
4757     /* If we haven't done anything yet... */
4758     if (dd->count == 0)
4759         return;
4760
4761     /* Remember some state, and clear it. */
4762     vms_wantversions = dd->vms_wantversions;
4763     dd->vms_wantversions = 0;
4764     _ckvmssts(lib$find_file_end(&dd->context));
4765     dd->context = 0;
4766
4767     /* The increment is in readdir(). */
4768     for (dd->count = 0; dd->count < count; )
4769         (void)readdir(dd);
4770
4771     dd->vms_wantversions = vms_wantversions;
4772
4773 }  /* end of seekdir() */
4774 /*}}}*/
4775
4776 /* VMS subprocess management
4777  *
4778  * my_vfork() - just a vfork(), after setting a flag to record that
4779  * the current script is trying a Unix-style fork/exec.
4780  *
4781  * vms_do_aexec() and vms_do_exec() are called in response to the
4782  * perl 'exec' function.  If this follows a vfork call, then they
4783  * call out the the regular perl routines in doio.c which do an
4784  * execvp (for those who really want to try this under VMS).
4785  * Otherwise, they do exactly what the perl docs say exec should
4786  * do - terminate the current script and invoke a new command
4787  * (See below for notes on command syntax.)
4788  *
4789  * do_aspawn() and do_spawn() implement the VMS side of the perl
4790  * 'system' function.
4791  *
4792  * Note on command arguments to perl 'exec' and 'system': When handled
4793  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4794  * are concatenated to form a DCL command string.  If the first arg
4795  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4796  * the the command string is handed off to DCL directly.  Otherwise,
4797  * the first token of the command is taken as the filespec of an image
4798  * to run.  The filespec is expanded using a default type of '.EXE' and
4799  * the process defaults for device, directory, etc., and if found, the resultant
4800  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4801  * the command string as parameters.  This is perhaps a bit complicated,
4802  * but I hope it will form a happy medium between what VMS folks expect
4803  * from lib$spawn and what Unix folks expect from exec.
4804  */
4805
4806 static int vfork_called;
4807
4808 /*{{{int my_vfork()*/
4809 int
4810 my_vfork()
4811 {
4812   vfork_called++;
4813   return vfork();
4814 }
4815 /*}}}*/
4816
4817
4818 static void
4819 vms_execfree(pTHX) {
4820   if (PL_Cmd) {
4821     if (PL_Cmd != VMSCMD.dsc$a_pointer) Safefree(PL_Cmd);
4822     PL_Cmd = Nullch;
4823   }
4824   if (VMSCMD.dsc$a_pointer) {
4825     Safefree(VMSCMD.dsc$a_pointer);
4826     VMSCMD.dsc$w_length = 0;
4827     VMSCMD.dsc$a_pointer = Nullch;
4828   }
4829 }
4830
4831 static char *
4832 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4833 {
4834   char *junk, *tmps = Nullch;
4835   register size_t cmdlen = 0;
4836   size_t rlen;
4837   register SV **idx;
4838   STRLEN n_a;
4839
4840   idx = mark;
4841   if (really) {
4842     tmps = SvPV(really,rlen);
4843     if (*tmps) {
4844       cmdlen += rlen + 1;
4845       idx++;
4846     }
4847   }
4848
4849   for (idx++; idx <= sp; idx++) {
4850     if (*idx) {
4851       junk = SvPVx(*idx,rlen);
4852       cmdlen += rlen ? rlen + 1 : 0;
4853     }
4854   }
4855   New(401,PL_Cmd,cmdlen+1,char);
4856
4857   if (tmps && *tmps) {
4858     strcpy(PL_Cmd,tmps);
4859     mark++;
4860   }
4861   else *PL_Cmd = '\0';
4862   while (++mark <= sp) {
4863     if (*mark) {
4864       char *s = SvPVx(*mark,n_a);
4865       if (!*s) continue;
4866       if (*PL_Cmd) strcat(PL_Cmd," ");
4867       strcat(PL_Cmd,s);
4868     }
4869   }
4870   return PL_Cmd;
4871
4872 }  /* end of setup_argstr() */
4873
4874
4875 static unsigned long int
4876 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote)
4877 {
4878   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4879   $DESCRIPTOR(defdsc,".EXE");
4880   $DESCRIPTOR(defdsc2,".");
4881   $DESCRIPTOR(resdsc,resspec);
4882   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4883   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4884   register char *s, *rest, *cp, *wordbreak;
4885   register int isdcl;
4886
4887   if (suggest_quote) *suggest_quote = 0;
4888
4889   if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
4890     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
4891   s = cmd;
4892   while (*s && isspace(*s)) s++;
4893
4894   if (*s == '@' || *s == '$') {
4895     vmsspec[0] = *s;  rest = s + 1;
4896     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4897   }
4898   else { cp = vmsspec; rest = s; }
4899   if (*rest == '.' || *rest == '/') {
4900     char *cp2;
4901     for (cp2 = resspec;
4902          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4903          rest++, cp2++) *cp2 = *rest;
4904     *cp2 = '\0';
4905     if (do_tovmsspec(resspec,cp,0)) {
4906       s = vmsspec;
4907       if (*rest) {
4908         for (cp2 = vmsspec + strlen(vmsspec);
4909              *rest && cp2 - vmsspec < sizeof vmsspec;
4910              rest++, cp2++) *cp2 = *rest;
4911         *cp2 = '\0';
4912       }
4913     }
4914   }
4915   /* Intuit whether verb (first word of cmd) is a DCL command:
4916    *   - if first nonspace char is '@', it's a DCL indirection
4917    * otherwise
4918    *   - if verb contains a filespec separator, it's not a DCL command
4919    *   - if it doesn't, caller tells us whether to default to a DCL
4920    *     command, or to a local image unless told it's DCL (by leading '$')
4921    */
4922   if (*s == '@') {
4923       isdcl = 1;
4924       if (suggest_quote) *suggest_quote = 1;
4925   } else {
4926     register char *filespec = strpbrk(s,":<[.;");
4927     rest = wordbreak = strpbrk(s," \"\t/");
4928     if (!wordbreak) wordbreak = s + strlen(s);
4929     if (*s == '$') check_img = 0;
4930     if (filespec && (filespec < wordbreak)) isdcl = 0;
4931     else isdcl = !check_img;
4932   }
4933
4934   if (!isdcl) {
4935     imgdsc.dsc$a_pointer = s;
4936     imgdsc.dsc$w_length = wordbreak - s;
4937     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4938     if (!(retsts&1)) {
4939         _ckvmssts(lib$find_file_end(&cxt));
4940         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4941     if (!(retsts & 1) && *s == '$') {
4942           _ckvmssts(lib$find_file_end(&cxt));
4943       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4944       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4945           if (!(retsts&1)) {
4946       _ckvmssts(lib$find_file_end(&cxt));
4947             retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4948           }
4949     }
4950     }
4951     _ckvmssts(lib$find_file_end(&cxt));
4952
4953     if (retsts & 1) {
4954       FILE *fp;
4955       s = resspec;
4956       while (*s && !isspace(*s)) s++;
4957       *s = '\0';
4958
4959       /* check that it's really not DCL with no file extension */
4960       fp = fopen(resspec,"r","ctx=bin,shr=get");
4961       if (fp) {
4962         char b[4] = {0,0,0,0};
4963         read(fileno(fp),b,4);
4964         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4965         fclose(fp);
4966       }
4967       if (check_img && isdcl) return RMS$_FNF;
4968
4969       if (cando_by_name(S_IXUSR,0,resspec)) {
4970         New(402,VMSCMD.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4971         if (!isdcl) {
4972             strcpy(VMSCMD.dsc$a_pointer,"$ MCR ");
4973             if (suggest_quote) *suggest_quote = 1;
4974         } else {
4975             strcpy(VMSCMD.dsc$a_pointer,"@");
4976             if (suggest_quote) *suggest_quote = 1;
4977         }
4978         strcat(VMSCMD.dsc$a_pointer,resspec);
4979         if (rest) strcat(VMSCMD.dsc$a_pointer,rest);
4980         VMSCMD.dsc$w_length = strlen(VMSCMD.dsc$a_pointer);
4981         return (VMSCMD.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
4982       }
4983       else retsts = RMS$_PRV;
4984     }
4985   }
4986   /* It's either a DCL command or we couldn't find a suitable image */
4987   VMSCMD.dsc$w_length = strlen(cmd);
4988   if (cmd == PL_Cmd) {
4989       VMSCMD.dsc$a_pointer = PL_Cmd;
4990       if (suggest_quote) *suggest_quote = 1;
4991   }
4992   else VMSCMD.dsc$a_pointer = savepvn(cmd,VMSCMD.dsc$w_length);
4993
4994   /* check if it's a symbol (for quoting purposes) */
4995   if (suggest_quote && !*suggest_quote) {
4996     int iss;
4997     char equiv[LNM$C_NAMLENGTH];
4998     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4999     eqvdsc.dsc$a_pointer = equiv;
5000
5001     iss = lib$get_symbol(&VMSCMD,&eqvdsc);
5002     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5003   }
5004   if (!(retsts & 1)) {
5005     /* just hand off status values likely to be due to user error */
5006     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5007         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5008        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5009     else { _ckvmssts(retsts); }
5010   }
5011
5012   return (VMSCMD.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5013
5014 }  /* end of setup_cmddsc() */
5015
5016
5017 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5018 bool
5019 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5020 {
5021   if (sp > mark) {
5022     if (vfork_called) {           /* this follows a vfork - act Unixish */
5023       vfork_called--;
5024       if (vfork_called < 0) {
5025         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5026         vfork_called = 0;
5027       }
5028       else return do_aexec(really,mark,sp);
5029     }
5030                                            /* no vfork - act VMSish */
5031     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5032
5033   }
5034
5035   return FALSE;
5036 }  /* end of vms_do_aexec() */
5037 /*}}}*/
5038
5039 /* {{{bool vms_do_exec(char *cmd) */
5040 bool
5041 Perl_vms_do_exec(pTHX_ char *cmd)
5042 {
5043
5044   if (vfork_called) {             /* this follows a vfork - act Unixish */
5045     vfork_called--;
5046     if (vfork_called < 0) {
5047       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5048       vfork_called = 0;
5049     }
5050     else return do_exec(cmd);
5051   }
5052
5053   {                               /* no vfork - act VMSish */
5054     unsigned long int retsts;
5055
5056     TAINT_ENV();
5057     TAINT_PROPER("exec");
5058     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0)) & 1)
5059       retsts = lib$do_command(&VMSCMD);
5060
5061     switch (retsts) {
5062       case RMS$_FNF: case RMS$_DNF:
5063         set_errno(ENOENT); break;
5064       case RMS$_DIR:
5065         set_errno(ENOTDIR); break;
5066       case RMS$_DEV:
5067         set_errno(ENODEV); break;
5068       case RMS$_PRV:
5069         set_errno(EACCES); break;
5070       case RMS$_SYN:
5071         set_errno(EINVAL); break;
5072       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5073         set_errno(E2BIG); break;
5074       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5075         _ckvmssts(retsts); /* fall through */
5076       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5077         set_errno(EVMSERR);
5078     }
5079     set_vaxc_errno(retsts);
5080     if (ckWARN(WARN_EXEC)) {
5081       Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
5082              VMSCMD.dsc$w_length, VMSCMD.dsc$a_pointer, Strerror(errno));
5083     }
5084     vms_execfree(aTHX);
5085   }
5086
5087   return FALSE;
5088
5089 }  /* end of vms_do_exec() */
5090 /*}}}*/
5091
5092 unsigned long int Perl_do_spawn(pTHX_ char *);
5093
5094 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5095 unsigned long int
5096 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5097 {
5098   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5099
5100   return SS$_ABORT;
5101 }  /* end of do_aspawn() */
5102 /*}}}*/
5103
5104 /* {{{unsigned long int do_spawn(char *cmd) */
5105 unsigned long int
5106 Perl_do_spawn(pTHX_ char *cmd)
5107 {
5108   unsigned long int sts, substs;
5109
5110   TAINT_ENV();
5111   TAINT_PROPER("spawn");
5112   if (!cmd || !*cmd) {
5113     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5114     if (!(sts & 1)) {
5115       switch (sts) {
5116         case RMS$_FNF:  case RMS$_DNF:
5117           set_errno(ENOENT); break;
5118         case RMS$_DIR:
5119           set_errno(ENOTDIR); break;
5120         case RMS$_DEV:
5121           set_errno(ENODEV); break;
5122         case RMS$_PRV:
5123           set_errno(EACCES); break;
5124         case RMS$_SYN:
5125           set_errno(EINVAL); break;
5126         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5127           set_errno(E2BIG); break;
5128         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5129           _ckvmssts(sts); /* fall through */
5130         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5131           set_errno(EVMSERR);
5132       }
5133       set_vaxc_errno(sts);
5134       if (ckWARN(WARN_EXEC)) {
5135         Perl_warner(aTHX_ WARN_EXEC,"Can't spawn: %s",
5136                     Strerror(errno));
5137       }
5138     }
5139     sts = substs;
5140   }
5141   else {
5142     (void) safe_popen(cmd, "nW", (int *)&sts);
5143   }
5144   return sts;
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);         /* will redo any earlier attempts */
7153
7154   return;
7155 }
7156
7157 /*  End of vms.c */