vms/vms.c

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