vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  * Version: 5.7.0
   5  *
   6  * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
   7  *             and Perl_cando by Craig Berry
   8  * 29-Aug-2000 Charles Lane's piping improvements rolled in
   9  * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  10  */
  11
  12 #include <acedef.h>
  13 #include <acldef.h>
  14 #include <armdef.h>
  15 #include <atrdef.h>
  16 #include <chpdef.h>
  17 #include <clidef.h>
  18 #include <climsgdef.h>
  19 #include <descrip.h>
  20 #include <devdef.h>
  21 #include <dvidef.h>
  22 #include <fibdef.h>
  23 #include <float.h>
  24 #include <fscndef.h>
  25 #include <iodef.h>
  26 #include <jpidef.h>
  27 #include <kgbdef.h>
  28 #include <libclidef.h>
  29 #include <libdef.h>
  30 #include <lib$routines.h>
  31 #include <lnmdef.h>
  32 #include <msgdef.h>
  33 #include <prvdef.h>
  34 #include <psldef.h>
  35 #include <rms.h>
  36 #include <shrdef.h>
  37 #include <ssdef.h>
  38 #include <starlet.h>
  39 #include <strdef.h>
  40 #include <str$routines.h>
  41 #include <syidef.h>
  42 #include <uaidef.h>
  43 #include <uicdef.h>
  44
  45 /* Older versions of ssdef.h don't have these */
  46 #ifndef SS$_INVFILFOROP
  47 #  define SS$_INVFILFOROP 3930
  48 #endif
  49 #ifndef SS$_NOSUCHOBJECT
  50 #  define SS$_NOSUCHOBJECT 2696
  51 #endif
  52
  53 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
  54 #define PERLIO_NOT_STDIO 0
  55
  56 /* Don't replace system definitions of vfork, getenv, and stat,
  57  * code below needs to get to the underlying CRTL routines. */
  58 #define DONT_MASK_RTL_CALLS
  59 #include "EXTERN.h"
  60 #include "perl.h"
  61 #include "XSUB.h"
  62 /* Anticipating future expansion in lexical warnings . . . */
  63 #ifndef WARN_INTERNAL
  64 #  define WARN_INTERNAL WARN_MISC
  65 #endif
  66
  67 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
  68 #  define RTL_USES_UTC 1
  69 #endif
  70
  71
  72 /* gcc's header files don't #define direct access macros
  73  * corresponding to VAXC's variant structs */
  74 #ifdef __GNUC__
  75 #  define uic$v_format uic$r_uic_form.uic$v_format
  76 #  define uic$v_group uic$r_uic_form.uic$v_group
  77 #  define uic$v_member uic$r_uic_form.uic$v_member
  78 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
  79 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
  80 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
  81 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
  82 #endif
  83
  84 #if defined(NEED_AN_H_ERRNO)
  85 dEXT int h_errno;
  86 #endif
  87
  88 struct itmlst_3 {
  89   unsigned short int buflen;
  90   unsigned short int itmcode;
  91   void *bufadr;
  92   unsigned short int *retlen;
  93 };
  94
  95 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
  96 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
  97 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
  98 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
  99 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
 100 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
 101 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
 102 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 103 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 104
 105 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 106 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 107
 108 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 109  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 110  * the Perl facility.
 111  */
 112 #define PERL_LNM_MAX_ITER 10
 113
 114 #define MAX_DCL_SYMBOL              255     /* well, what *we* can set, at least*/
 115 #define MAX_DCL_LINE_LENGTH        (4*MAX_DCL_SYMBOL-4)
 116
 117 static char *__mystrtolower(char *str)
 118 {
 119   if (str) for (; *str; ++str) *str= tolower(*str);
 120   return str;
 121 }
 122
 123 static struct dsc$descriptor_s fildevdsc =
 124   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 125 static struct dsc$descriptor_s crtlenvdsc =
 126   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 127 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 128 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 129 static struct dsc$descriptor_s **env_tables = defenv;
 130 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 131
 132 /* True if we shouldn't treat barewords as logicals during directory */
 133 /* munching */
 134 static int no_translate_barewords;
 135
 136 #ifndef RTL_USES_UTC
 137 static int tz_updated = 1;
 138 #endif
 139
 140 /* my_maxidx
 141  * Routine to retrieve the maximum equivalence index for an input
 142  * logical name.  Some calls to this routine have no knowledge if
 143  * the variable is a logical or not.  So on error we return a max
 144  * index of zero.
 145  */
 146 /*{{{int my_maxidx(char *lnm) */
 147 static int
 148 my_maxidx(char *lnm)
 149 {
 150     int status;
 151     int midx;
 152     int attr = LNM$M_CASE_BLIND;
 153     struct dsc$descriptor lnmdsc;
 154     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 155                                 {0, 0, 0, 0}};
 156
 157     lnmdsc.dsc$w_length = strlen(lnm);
 158     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 159     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 160     lnmdsc.dsc$a_pointer = lnm;
 161
 162     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 163     if ((status & 1) == 0)
 164        midx = 0;
 165
 166     return (midx);
 167 }
 168 /*}}}*/
 169
 170 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 171 int
 172 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 173   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 174 {
 175     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
 176     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 177     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 178     int midx;
 179     unsigned char acmode;
 180     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 181                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 182     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 183                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 184                                  {0, 0, 0, 0}};
 185     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 186 #if defined(PERL_IMPLICIT_CONTEXT)
 187     pTHX = NULL;
 188     if (PL_curinterp) {
 189       aTHX = PERL_GET_INTERP;
 190     } else {
 191       aTHX = NULL;
 192     }
 193 #endif
 194
 195     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 196       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 197     }
 198     for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 199       *cp2 = _toupper(*cp1);
 200       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 201         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 202         return 0;
 203       }
 204     }
 205     lnmdsc.dsc$w_length = cp1 - lnm;
 206     lnmdsc.dsc$a_pointer = uplnm;
 207     uplnm[lnmdsc.dsc$w_length] = '\0';
 208     secure = flags & PERL__TRNENV_SECURE;
 209     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 210     if (!tabvec || !*tabvec) tabvec = env_tables;
 211
 212     for (curtab = 0; tabvec[curtab]; curtab++) {
 213       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 214         if (!ivenv && !secure) {
 215           char *eq, *end;
 216           int i;
 217           if (!environ) {
 218             ivenv = 1;
 219             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 220             continue;
 221           }
 222           retsts = SS$_NOLOGNAM;
 223           for (i = 0; environ[i]; i++) {
 224             if ((eq = strchr(environ[i],'=')) &&
 225                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 226                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 227               eq++;
 228               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 229               if (!eqvlen) continue;
 230               retsts = SS$_NORMAL;
 231               break;
 232             }
 233           }
 234           if (retsts != SS$_NOLOGNAM) break;
 235         }
 236       }
 237       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 238                !str$case_blind_compare(&tmpdsc,&clisym)) {
 239         if (!ivsym && !secure) {
 240           unsigned short int deflen = LNM$C_NAMLENGTH;
 241           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 242           /* dynamic dsc to accomodate possible long value */
 243           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 244           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 245           if (retsts & 1) {
 246             if (eqvlen > 1024) {
 247               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 248               eqvlen = 1024;
 249               /* Special hack--we might be called before the interpreter's */
 250               /* fully initialized, in which case either thr or PL_curcop */
 251               /* might be bogus. We have to check, since ckWARN needs them */
 252               /* both to be valid if running threaded */
 253                 if (ckWARN(WARN_MISC)) {
 254                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 255                 }
 256             }
 257             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 258           }
 259           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 260           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 261           if (retsts == LIB$_NOSUCHSYM) continue;
 262           break;
 263         }
 264       }
 265       else if (!ivlnm) {
 266         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 267           midx = my_maxidx((char *) lnm);
 268           for (idx = 0, cp1 = eqv; idx <= midx; idx++) {
 269             lnmlst[1].bufadr = cp1;
 270             eqvlen = 0;
 271             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 272             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 273             if (retsts == SS$_NOLOGNAM) break;
 274             /* PPFs have a prefix */
 275             if (
 276 #if INTSIZE == 4
 277                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 278 #endif
 279                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 280                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 281                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 282                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 283                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 284               memcpy(eqv,eqv+4,eqvlen-4);
 285               eqvlen -= 4;
 286             }
 287             cp1 += eqvlen;
 288             *cp1 = '\0';
 289           }
 290           if ((retsts == SS$_IVLOGNAM) ||
 291               (retsts == SS$_NOLOGNAM)) { continue; }
 292         }
 293         else {
 294           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 295           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 296           if (retsts == SS$_NOLOGNAM) continue;
 297           eqv[eqvlen] = '\0';
 298         }
 299         eqvlen = strlen(eqv);
 300         break;
 301       }
 302     }
 303     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 304     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 305              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 306              retsts == SS$_NOLOGNAM) {
 307       set_errno(EINVAL);  set_vaxc_errno(retsts);
 308     }
 309     else _ckvmssts(retsts);
 310     return 0;
 311 }  /* end of vmstrnenv */
 312 /*}}}*/
 313
 314 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 315 /* Define as a function so we can access statics. */
 316 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 317 {
 318   return vmstrnenv(lnm,eqv,idx,fildev,
 319 #ifdef SECURE_INTERNAL_GETENV
 320                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 321 #else
 322                    0
 323 #endif
 324                                                                               );
 325 }
 326 /*}}}*/
 327
 328 /* my_getenv
 329  * Note: Uses Perl temp to store result so char * can be returned to
 330  * caller; this pointer will be invalidated at next Perl statement
 331  * transition.
 332  * We define this as a function rather than a macro in terms of my_getenv_len()
 333  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 334  * allocate SVs).
 335  */
 336 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 337 char *
 338 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 339 {
 340     static char *__my_getenv_eqv = NULL;
 341     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
 342     unsigned long int idx = 0;
 343     int trnsuccess, success, secure, saverr, savvmserr;
 344     int midx, flags;
 345     SV *tmpsv;
 346
 347     midx = my_maxidx((char *) lnm) + 1;
 348
 349     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 350       /* Set up a temporary buffer for the return value; Perl will
 351        * clean it up at the next statement transition */
 352       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 353       if (!tmpsv) return NULL;
 354       eqv = SvPVX(tmpsv);
 355     }
 356     else {
 357       /* Assume no interpreter ==> single thread */
 358       if (__my_getenv_eqv != NULL) {
 359         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 360       }
 361       else {
 362         New(1380,__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 363       }
 364       eqv = __my_getenv_eqv;
 365     }
 366
 367     for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 368     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 369       getcwd(eqv,LNM$C_NAMLENGTH);
 370       return eqv;
 371     }
 372     else {
 373       /* Impose security constraints only if tainting */
 374       if (sys) {
 375         /* Impose security constraints only if tainting */
 376         secure = PL_curinterp ? PL_tainting : will_taint;
 377         saverr = errno;  savvmserr = vaxc$errno;
 378       }
 379       else {
 380         secure = 0;
 381       }
 382
 383       flags =
 384 #ifdef SECURE_INTERNAL_GETENV
 385               secure ? PERL__TRNENV_SECURE : 0
 386 #else
 387               0
 388 #endif
 389       ;
 390
 391       /* For the getenv interface we combine all the equivalence names
 392        * of a search list logical into one value to acquire a maximum
 393        * value length of 255*128 (assuming %ENV is using logicals).
 394        */
 395       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 396
 397       /* If the name contains a semicolon-delimited index, parse it
 398        * off and make sure we only retrieve the equivalence name for
 399        * that index.  */
 400       if ((cp2 = strchr(lnm,';')) != NULL) {
 401         strcpy(uplnm,lnm);
 402         uplnm[cp2-lnm] = '\0';
 403         idx = strtoul(cp2+1,NULL,0);
 404         lnm = uplnm;
 405         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 406       }
 407
 408       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
 409
 410       /* Discard NOLOGNAM on internal calls since we're often looking
 411        * for an optional name, and this "error" often shows up as the
 412        * (bogus) exit status for a die() call later on.  */
 413       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 414       return success ? eqv : Nullch;
 415     }
 416
 417 }  /* end of my_getenv() */
 418 /*}}}*/
 419
 420
 421 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 422 char *
 423 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 424 {
 425     char *buf, *cp1, *cp2;
 426     unsigned long idx = 0;
 427     int midx, flags;
 428     static char *__my_getenv_len_eqv = NULL;
 429     int secure, saverr, savvmserr;
 430     SV *tmpsv;
 431
 432     midx = my_maxidx((char *) lnm) + 1;
 433
 434     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 435       /* Set up a temporary buffer for the return value; Perl will
 436        * clean it up at the next statement transition */
 437       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 438       if (!tmpsv) return NULL;
 439       buf = SvPVX(tmpsv);
 440     }
 441     else {
 442       /* Assume no interpreter ==> single thread */
 443       if (__my_getenv_len_eqv != NULL) {
 444         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 445       }
 446       else {
 447         New(1381,__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 448       }
 449       buf = __my_getenv_len_eqv;
 450     }
 451
 452     for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 453     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 454       getcwd(buf,LNM$C_NAMLENGTH);
 455       *len = strlen(buf);
 456       return buf;
 457     }
 458     else {
 459       if (sys) {
 460         /* Impose security constraints only if tainting */
 461         secure = PL_curinterp ? PL_tainting : will_taint;
 462         saverr = errno;  savvmserr = vaxc$errno;
 463       }
 464       else {
 465         secure = 0;
 466       }
 467
 468       flags =
 469 #ifdef SECURE_INTERNAL_GETENV
 470               secure ? PERL__TRNENV_SECURE : 0
 471 #else
 472               0
 473 #endif
 474       ;
 475
 476       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 477
 478       if ((cp2 = strchr(lnm,';')) != NULL) {
 479         strcpy(buf,lnm);
 480         buf[cp2-lnm] = '\0';
 481         idx = strtoul(cp2+1,NULL,0);
 482         lnm = buf;
 483         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 484       }
 485
 486       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
 487
 488       /* Discard NOLOGNAM on internal calls since we're often looking
 489        * for an optional name, and this "error" often shows up as the
 490        * (bogus) exit status for a die() call later on.  */
 491       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 492       return *len ? buf : Nullch;
 493     }
 494
 495 }  /* end of my_getenv_len() */
 496 /*}}}*/
 497
 498 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 499
 500 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 501
 502 /*{{{ void prime_env_iter() */
 503 void
 504 prime_env_iter(void)
 505 /* Fill the %ENV associative array with all logical names we can
 506  * find, in preparation for iterating over it.
 507  */
 508 {
 509   static int primed = 0;
 510   HV *seenhv = NULL, *envhv;
 511   SV *sv = NULL;
 512   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 513   unsigned short int chan;
 514 #ifndef CLI$M_TRUSTED
 515 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 516 #endif
 517   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 518   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 519   long int i;
 520   bool have_sym = FALSE, have_lnm = FALSE;
 521   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 522   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 523   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 524   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 525   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 526 #if defined(PERL_IMPLICIT_CONTEXT)
 527   pTHX;
 528 #endif
 529 #if defined(USE_ITHREADS)
 530   static perl_mutex primenv_mutex;
 531   MUTEX_INIT(&primenv_mutex);
 532 #endif
 533
 534 #if defined(PERL_IMPLICIT_CONTEXT)
 535     /* We jump through these hoops because we can be called at */
 536     /* platform-specific initialization time, which is before anything is */
 537     /* set up--we can't even do a plain dTHX since that relies on the */
 538     /* interpreter structure to be initialized */
 539     if (PL_curinterp) {
 540       aTHX = PERL_GET_INTERP;
 541     } else {
 542       aTHX = NULL;
 543     }
 544 #endif
 545
 546   if (primed || !PL_envgv) return;
 547   MUTEX_LOCK(&primenv_mutex);
 548   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
 549   envhv = GvHVn(PL_envgv);
 550   /* Perform a dummy fetch as an lval to insure that the hash table is
 551    * set up.  Otherwise, the hv_store() will turn into a nullop. */
 552   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
 553
 554   for (i = 0; env_tables[i]; i++) {
 555      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 556          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
 557      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
 558   }
 559   if (have_sym || have_lnm) {
 560     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 561     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 562     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
 563     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
 564   }
 565
 566   for (i--; i >= 0; i--) {
 567     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
 568       char *start;
 569       int j;
 570       for (j = 0; environ[j]; j++) {
 571         if (!(start = strchr(environ[j],'='))) {
 572           if (ckWARN(WARN_INTERNAL))
 573             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
 574         }
 575         else {
 576           start++;
 577           sv = newSVpv(start,0);
 578           SvTAINTED_on(sv);
 579           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
 580         }
 581       }
 582       continue;
 583     }
 584     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 585              !str$case_blind_compare(&tmpdsc,&clisym)) {
 586       strcpy(cmd,"Show Symbol/Global *");
 587       cmddsc.dsc$w_length = 20;
 588       if (env_tables[i]->dsc$w_length == 12 &&
 589           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
 590           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
 591       flags = defflags | CLI$M_NOLOGNAM;
 592     }
 593     else {
 594       strcpy(cmd,"Show Logical *");
 595       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
 596         strcat(cmd," /Table=");
 597         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
 598         cmddsc.dsc$w_length = strlen(cmd);
 599       }
 600       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
 601       flags = defflags | CLI$M_NOCLISYM;
 602     }
 603
 604     /* Create a new subprocess to execute each command, to exclude the
 605      * remote possibility that someone could subvert a mbx or file used
 606      * to write multiple commands to a single subprocess.
 607      */
 608     do {
 609       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
 610                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
 611       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
 612       defflags &= ~CLI$M_TRUSTED;
 613     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
 614     _ckvmssts(retsts);
 615     if (!buf) New(1322,buf,mbxbufsiz + 1,char);
 616     if (seenhv) SvREFCNT_dec(seenhv);
 617     seenhv = newHV();
 618     while (1) {
 619       char *cp1, *cp2, *key;
 620       unsigned long int sts, iosb[2], retlen, keylen;
 621       register U32 hash;
 622
 623       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
 624       if (sts & 1) sts = iosb[0] & 0xffff;
 625       if (sts == SS$_ENDOFFILE) {
 626         int wakect = 0;
 627         while (substs == 0) { sys$hiber(); wakect++;}
 628         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
 629         _ckvmssts(substs);
 630         break;
 631       }
 632       _ckvmssts(sts);
 633       retlen = iosb[0] >> 16;
 634       if (!retlen) continue;  /* blank line */
 635       buf[retlen] = '\0';
 636       if (iosb[1] != subpid) {
 637         if (iosb[1]) {
 638           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
 639         }
 640         continue;
 641       }
 642       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
 643         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
 644
 645       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
 646       if (*cp1 == '(' || /* Logical name table name */
 647           *cp1 == '='    /* Next eqv of searchlist  */) continue;
 648       if (*cp1 == '"') cp1++;
 649       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
 650       key = cp1;  keylen = cp2 - cp1;
 651       if (keylen && hv_exists(seenhv,key,keylen)) continue;
 652       while (*cp2 && *cp2 != '=') cp2++;
 653       while (*cp2 && *cp2 == '=') cp2++;
 654       while (*cp2 && *cp2 == ' ') cp2++;
 655       if (*cp2 == '"') {  /* String translation; may embed "" */
 656         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
 657         cp2++;  cp1--; /* Skip "" surrounding translation */
 658       }
 659       else {  /* Numeric translation */
 660         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
 661         cp1--;  /* stop on last non-space char */
 662       }
 663       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
 664         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
 665         continue;
 666       }
 667       PERL_HASH(hash,key,keylen);
 668
 669       if (cp1 == cp2 && *cp2 == '.') {
 670         /* A single dot usually means an unprintable character, such as a null
 671          * to indicate a zero-length value.  Get the actual value to make sure.
 672          */
 673         char lnm[LNM$C_NAMLENGTH+1];
 674         char eqv[LNM$C_NAMLENGTH+1];
 675         strncpy(lnm, key, keylen);
 676         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
 677         sv = newSVpvn(eqv, strlen(eqv));
 678       }
 679       else {
 680         sv = newSVpvn(cp2,cp1 - cp2 + 1);
 681       }
 682
 683       SvTAINTED_on(sv);
 684       hv_store(envhv,key,keylen,sv,hash);
 685       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
 686     }
 687     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
 688       /* get the PPFs for this process, not the subprocess */
 689       char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
 690       char eqv[LNM$C_NAMLENGTH+1];
 691       int trnlen, i;
 692       for (i = 0; ppfs[i]; i++) {
 693         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
 694         sv = newSVpv(eqv,trnlen);
 695         SvTAINTED_on(sv);
 696         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
 697       }
 698     }
 699   }
 700   primed = 1;
 701   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
 702   if (buf) Safefree(buf);
 703   if (seenhv) SvREFCNT_dec(seenhv);
 704   MUTEX_UNLOCK(&primenv_mutex);
 705   return;
 706
 707 }  /* end of prime_env_iter */
 708 /*}}}*/
 709
 710
 711 /*{{{ int  vmssetenv(char *lnm, char *eqv)*/
 712 /* Define or delete an element in the same "environment" as
 713  * vmstrnenv().  If an element is to be deleted, it's removed from
 714  * the first place it's found.  If it's to be set, it's set in the
 715  * place designated by the first element of the table vector.
 716  * Like setenv() returns 0 for success, non-zero on error.
 717  */
 718 int
 719 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
 720 {
 721     char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2, *c;
 722     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
 723     int nseg = 0, j;
 724     unsigned long int retsts, usermode = PSL$C_USER;
 725     struct itmlst_3 *ile, *ilist;
 726     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 727                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 728                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 729     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 730     $DESCRIPTOR(local,"_LOCAL");
 731
 732     if (!lnm) {
 733         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 734         return SS$_IVLOGNAM;
 735     }
 736
 737     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 738       *cp2 = _toupper(*cp1);
 739       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 740         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 741         return SS$_IVLOGNAM;
 742       }
 743     }
 744     lnmdsc.dsc$w_length = cp1 - lnm;
 745     if (!tabvec || !*tabvec) tabvec = env_tables;
 746
 747     if (!eqv) {  /* we're deleting n element */
 748       for (curtab = 0; tabvec[curtab]; curtab++) {
 749         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 750         int i;
 751           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
 752             if ((cp1 = strchr(environ[i],'=')) &&
 753                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
 754                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
 755 #ifdef HAS_SETENV
 756               return setenv(lnm,"",1) ? vaxc$errno : 0;
 757             }
 758           }
 759           ivenv = 1; retsts = SS$_NOLOGNAM;
 760 #else
 761               if (ckWARN(WARN_INTERNAL))
 762                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
 763               ivenv = 1; retsts = SS$_NOSUCHPGM;
 764               break;
 765             }
 766           }
 767 #endif
 768         }
 769         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 770                  !str$case_blind_compare(&tmpdsc,&clisym)) {
 771           unsigned int symtype;
 772           if (tabvec[curtab]->dsc$w_length == 12 &&
 773               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
 774               !str$case_blind_compare(&tmpdsc,&local))
 775             symtype = LIB$K_CLI_LOCAL_SYM;
 776           else symtype = LIB$K_CLI_GLOBAL_SYM;
 777           retsts = lib$delete_symbol(&lnmdsc,&symtype);
 778           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 779           if (retsts == LIB$_NOSUCHSYM) continue;
 780           break;
 781         }
 782         else if (!ivlnm) {
 783           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
 784           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 785           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 786           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
 787           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 788         }
 789       }
 790     }
 791     else {  /* we're defining a value */
 792       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
 793 #ifdef HAS_SETENV
 794         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 795 #else
 796         if (ckWARN(WARN_INTERNAL))
 797           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
 798         retsts = SS$_NOSUCHPGM;
 799 #endif
 800       }
 801       else {
 802         eqvdsc.dsc$a_pointer = eqv;
 803         eqvdsc.dsc$w_length  = strlen(eqv);
 804         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
 805             !str$case_blind_compare(&tmpdsc,&clisym)) {
 806           unsigned int symtype;
 807           if (tabvec[0]->dsc$w_length == 12 &&
 808               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
 809                !str$case_blind_compare(&tmpdsc,&local))
 810             symtype = LIB$K_CLI_LOCAL_SYM;
 811           else symtype = LIB$K_CLI_GLOBAL_SYM;
 812           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
 813         }
 814         else {
 815           if (!*eqv) eqvdsc.dsc$w_length = 1;
 816           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
 817
 818             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
 819             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
 820               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
 821                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
 822               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
 823               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
 824             }
 825
 826             New(1382,ilist,nseg+1,struct itmlst_3);
 827             ile = ilist;
 828             if (!ile) {
 829               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
 830               return SS$_INSFMEM;
 831             }
 832             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
 833
 834             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
 835               ile->itmcode = LNM$_STRING;
 836               ile->bufadr = c;
 837               if ((j+1) == nseg) {
 838                 ile->buflen = strlen(c);
 839                 /* in case we are truncating one that's too long */
 840                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
 841               }
 842               else {
 843                 ile->buflen = LNM$C_NAMLENGTH;
 844               }
 845             }
 846
 847             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
 848             Safefree (ilist);
 849           }
 850           else {
 851             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
 852           }
 853         }
 854       }
 855     }
 856     if (!(retsts & 1)) {
 857       switch (retsts) {
 858         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
 859         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
 860           set_errno(EVMSERR); break;
 861         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
 862         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
 863           set_errno(EINVAL); break;
 864         case SS$_NOPRIV:
 865           set_errno(EACCES);
 866         default:
 867           _ckvmssts(retsts);
 868           set_errno(EVMSERR);
 869        }
 870        set_vaxc_errno(retsts);
 871        return (int) retsts || 44; /* retsts should never be 0, but just in case */
 872     }
 873     else {
 874       /* We reset error values on success because Perl does an hv_fetch()
 875        * before each hv_store(), and if the thing we're setting didn't
 876        * previously exist, we've got a leftover error message.  (Of course,
 877        * this fails in the face of
 878        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
 879        * in that the error reported in $! isn't spurious,
 880        * but it's right more often than not.)
 881        */
 882       set_errno(0); set_vaxc_errno(retsts);
 883       return 0;
 884     }
 885
 886 }  /* end of vmssetenv() */
 887 /*}}}*/
 888
 889 /*{{{ void  my_setenv(char *lnm, char *eqv)*/
 890 /* This has to be a function since there's a prototype for it in proto.h */
 891 void
 892 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
 893 {
 894     if (lnm && *lnm) {
 895       int len = strlen(lnm);
 896       if  (len == 7) {
 897         char uplnm[8];
 898         int i;
 899         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
 900         if (!strcmp(uplnm,"DEFAULT")) {
 901           if (eqv && *eqv) chdir(eqv);
 902           return;
 903         }
 904     }
 905 #ifndef RTL_USES_UTC
 906     if (len == 6 || len == 2) {
 907       char uplnm[7];
 908       int i;
 909       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
 910       uplnm[len] = '\0';
 911       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
 912       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
 913     }
 914 #endif
 915   }
 916   (void) vmssetenv(lnm,eqv,NULL);
 917 }
 918 /*}}}*/
 919
 920 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
 921 /*  vmssetuserlnm
 922  *  sets a user-mode logical in the process logical name table
 923  *  used for redirection of sys$error
 924  */
 925 void
 926 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
 927 {
 928     $DESCRIPTOR(d_tab, "LNM$PROCESS");
 929     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 930     unsigned long int iss, attr = LNM$M_CONFINE;
 931     unsigned char acmode = PSL$C_USER;
 932     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
 933                                  {0, 0, 0, 0}};
 934     d_name.dsc$a_pointer = name;
 935     d_name.dsc$w_length = strlen(name);
 936
 937     lnmlst[0].buflen = strlen(eqv);
 938     lnmlst[0].bufadr = eqv;
 939
 940     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
 941     if (!(iss&1)) lib$signal(iss);
 942 }
 943 /*}}}*/
 944
 945
 946 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
 947 /* my_crypt - VMS password hashing
 948  * my_crypt() provides an interface compatible with the Unix crypt()
 949  * C library function, and uses sys$hash_password() to perform VMS
 950  * password hashing.  The quadword hashed password value is returned
 951  * as a NUL-terminated 8 character string.  my_crypt() does not change
 952  * the case of its string arguments; in order to match the behavior
 953  * of LOGINOUT et al., alphabetic characters in both arguments must
 954  *  be upcased by the caller.
 955  */
 956 char *
 957 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
 958 {
 959 #   ifndef UAI$C_PREFERRED_ALGORITHM
 960 #     define UAI$C_PREFERRED_ALGORITHM 127
 961 #   endif
 962     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
 963     unsigned short int salt = 0;
 964     unsigned long int sts;
 965     struct const_dsc {
 966         unsigned short int dsc$w_length;
 967         unsigned char      dsc$b_type;
 968         unsigned char      dsc$b_class;
 969         const char *       dsc$a_pointer;
 970     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
 971        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 972     struct itmlst_3 uailst[3] = {
 973         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
 974         { sizeof salt, UAI$_SALT,    &salt, 0},
 975         { 0,           0,            NULL,  NULL}};
 976     static char hash[9];
 977
 978     usrdsc.dsc$w_length = strlen(usrname);
 979     usrdsc.dsc$a_pointer = usrname;
 980     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
 981       switch (sts) {
 982         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
 983           set_errno(EACCES);
 984           break;
 985         case RMS$_RNF:
 986           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
 987           break;
 988         default:
 989           set_errno(EVMSERR);
 990       }
 991       set_vaxc_errno(sts);
 992       if (sts != RMS$_RNF) return NULL;
 993     }
 994
 995     txtdsc.dsc$w_length = strlen(textpasswd);
 996     txtdsc.dsc$a_pointer = textpasswd;
 997     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
 998       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
 999     }
1000
1001     return (char *) hash;
1002
1003 }  /* end of my_crypt() */
1004 /*}}}*/
1005
1006
1007 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
1008 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
1009 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
1010
1011 /*{{{int do_rmdir(char *name)*/
1012 int
1013 Perl_do_rmdir(pTHX_ char *name)
1014 {
1015     char dirfile[NAM$C_MAXRSS+1];
1016     int retval;
1017     Stat_t st;
1018
1019     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1020     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1021     else retval = kill_file(dirfile);
1022     return retval;
1023
1024 }  /* end of do_rmdir */
1025 /*}}}*/
1026
1027 /* kill_file
1028  * Delete any file to which user has control access, regardless of whether
1029  * delete access is explicitly allowed.
1030  * Limitations: User must have write access to parent directory.
1031  *              Does not block signals or ASTs; if interrupted in midstream
1032  *              may leave file with an altered ACL.
1033  * HANDLE WITH CARE!
1034  */
1035 /*{{{int kill_file(char *name)*/
1036 int
1037 Perl_kill_file(pTHX_ char *name)
1038 {
1039     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1040     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1041     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1042     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1043     struct myacedef {
1044       unsigned char myace$b_length;
1045       unsigned char myace$b_type;
1046       unsigned short int myace$w_flags;
1047       unsigned long int myace$l_access;
1048       unsigned long int myace$l_ident;
1049     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1050                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1051       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1052      struct itmlst_3
1053        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1054                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1055        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1056        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1057        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1058        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1059
1060     /* Expand the input spec using RMS, since the CRTL remove() and
1061      * system services won't do this by themselves, so we may miss
1062      * a file "hiding" behind a logical name or search list. */
1063     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1064     if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1065     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1066     /* If not, can changing protections help? */
1067     if (vaxc$errno != RMS$_PRV) return -1;
1068
1069     /* No, so we get our own UIC to use as a rights identifier,
1070      * and the insert an ACE at the head of the ACL which allows us
1071      * to delete the file.
1072      */
1073     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1074     fildsc.dsc$w_length = strlen(rspec);
1075     fildsc.dsc$a_pointer = rspec;
1076     cxt = 0;
1077     newace.myace$l_ident = oldace.myace$l_ident;
1078     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1079       switch (aclsts) {
1080         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1081           set_errno(ENOENT); break;
1082         case RMS$_DIR:
1083           set_errno(ENOTDIR); break;
1084         case RMS$_DEV:
1085           set_errno(ENODEV); break;
1086         case RMS$_SYN: case SS$_INVFILFOROP:
1087           set_errno(EINVAL); break;
1088         case RMS$_PRV:
1089           set_errno(EACCES); break;
1090         default:
1091           _ckvmssts(aclsts);
1092       }
1093       set_vaxc_errno(aclsts);
1094       return -1;
1095     }
1096     /* Grab any existing ACEs with this identifier in case we fail */
1097     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1098     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1099                     || fndsts == SS$_NOMOREACE ) {
1100       /* Add the new ACE . . . */
1101       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1102         goto yourroom;
1103       if ((rmsts = remove(name))) {
1104         /* We blew it - dir with files in it, no write priv for
1105          * parent directory, etc.  Put things back the way they were. */
1106         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1107           goto yourroom;
1108         if (fndsts & 1) {
1109           addlst[0].bufadr = &oldace;
1110           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1111             goto yourroom;
1112         }
1113       }
1114     }
1115
1116     yourroom:
1117     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1118     /* We just deleted it, so of course it's not there.  Some versions of
1119      * VMS seem to return success on the unlock operation anyhow (after all
1120      * the unlock is successful), but others don't.
1121      */
1122     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1123     if (aclsts & 1) aclsts = fndsts;
1124     if (!(aclsts & 1)) {
1125       set_errno(EVMSERR);
1126       set_vaxc_errno(aclsts);
1127       return -1;
1128     }
1129
1130     return rmsts;
1131
1132 }  /* end of kill_file() */
1133 /*}}}*/
1134
1135
1136 /*{{{int my_mkdir(char *,Mode_t)*/
1137 int
1138 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1139 {
1140   STRLEN dirlen = strlen(dir);
1141
1142   /* zero length string sometimes gives ACCVIO */
1143   if (dirlen == 0) return -1;
1144
1145   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1146    * null file name/type.  However, it's commonplace under Unix,
1147    * so we'll allow it for a gain in portability.
1148    */
1149   if (dir[dirlen-1] == '/') {
1150     char *newdir = savepvn(dir,dirlen-1);
1151     int ret = mkdir(newdir,mode);
1152     Safefree(newdir);
1153     return ret;
1154   }
1155   else return mkdir(dir,mode);
1156 }  /* end of my_mkdir */
1157 /*}}}*/
1158
1159 /*{{{int my_chdir(char *)*/
1160 int
1161 Perl_my_chdir(pTHX_ char *dir)
1162 {
1163   STRLEN dirlen = strlen(dir);
1164
1165   /* zero length string sometimes gives ACCVIO */
1166   if (dirlen == 0) return -1;
1167
1168   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1169    * that implies
1170    * null file name/type.  However, it's commonplace under Unix,
1171    * so we'll allow it for a gain in portability.
1172    */
1173   if (dir[dirlen-1] == '/') {
1174     char *newdir = savepvn(dir,dirlen-1);
1175     int ret = chdir(newdir);
1176     Safefree(newdir);
1177     return ret;
1178   }
1179   else return chdir(dir);
1180 }  /* end of my_chdir */
1181 /*}}}*/
1182
1183
1184 /*{{{FILE *my_tmpfile()*/
1185 FILE *
1186 my_tmpfile(void)
1187 {
1188   FILE *fp;
1189   char *cp;
1190
1191   if ((fp = tmpfile())) return fp;
1192
1193   New(1323,cp,L_tmpnam+24,char);
1194   strcpy(cp,"Sys$Scratch:");
1195   tmpnam(cp+strlen(cp));
1196   strcat(cp,".Perltmp");
1197   fp = fopen(cp,"w+","fop=dlt");
1198   Safefree(cp);
1199   return fp;
1200 }
1201 /*}}}*/
1202
1203
1204 #ifndef HOMEGROWN_POSIX_SIGNALS
1205 /*
1206  * The C RTL's sigaction fails to check for invalid signal numbers so we
1207  * help it out a bit.  The docs are correct, but the actual routine doesn't
1208  * do what the docs say it will.
1209  */
1210 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1211 int
1212 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1213                    struct sigaction* oact)
1214 {
1215   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1216         SETERRNO(EINVAL, SS$_INVARG);
1217         return -1;
1218   }
1219   return sigaction(sig, act, oact);
1220 }
1221 /*}}}*/
1222 #endif
1223
1224 #ifdef KILL_BY_SIGPRC
1225 #include <errnodef.h>
1226
1227 /* We implement our own kill() using the undocumented system service
1228    sys$sigprc for one of two reasons:
1229
1230    1.) If the kill() in an older CRTL uses sys$forcex, causing the
1231    target process to do a sys$exit, which usually can't be handled
1232    gracefully...certainly not by Perl and the %SIG{} mechanism.
1233
1234    2.) If the kill() in the CRTL can't be called from a signal
1235    handler without disappearing into the ether, i.e., the signal
1236    it purportedly sends is never trapped. Still true as of VMS 7.3.
1237
1238    sys$sigprc has the same parameters as sys$forcex, but throws an exception
1239    in the target process rather than calling sys$exit.
1240
1241    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1242    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1243    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
1244    with condition codes C$_SIG0+nsig*8, catching the exception on the
1245    target process and resignaling with appropriate arguments.
1246
1247    But we don't have that VMS 7.0+ exception handler, so if you
1248    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
1249
1250    Also note that SIGTERM is listed in the docs as being "unimplemented",
1251    yet always seems to be signaled with a VMS condition code of 4 (and
1252    correctly handled for that code).  So we hardwire it in.
1253
1254    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1255    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
1256    than signalling with an unrecognized (and unhandled by CRTL) code.
1257 */
1258
1259 #define _MY_SIG_MAX 17
1260
1261 unsigned int
1262 Perl_sig_to_vmscondition(int sig)
1263 {
1264     static unsigned int sig_code[_MY_SIG_MAX+1] =
1265     {
1266         0,                  /*  0 ZERO     */
1267         SS$_HANGUP,         /*  1 SIGHUP   */
1268         SS$_CONTROLC,       /*  2 SIGINT   */
1269         SS$_CONTROLY,       /*  3 SIGQUIT  */
1270         SS$_RADRMOD,        /*  4 SIGILL   */
1271         SS$_BREAK,          /*  5 SIGTRAP  */
1272         SS$_OPCCUS,         /*  6 SIGABRT  */
1273         SS$_COMPAT,         /*  7 SIGEMT   */
1274 #ifdef __VAX
1275         SS$_FLTOVF,         /*  8 SIGFPE VAX */
1276 #else
1277         SS$_HPARITH,        /*  8 SIGFPE AXP */
1278 #endif
1279         SS$_ABORT,          /*  9 SIGKILL  */
1280         SS$_ACCVIO,         /* 10 SIGBUS   */
1281         SS$_ACCVIO,         /* 11 SIGSEGV  */
1282         SS$_BADPARAM,       /* 12 SIGSYS   */
1283         SS$_NOMBX,          /* 13 SIGPIPE  */
1284         SS$_ASTFLT,         /* 14 SIGALRM  */
1285         4,                  /* 15 SIGTERM  */
1286         0,                  /* 16 SIGUSR1  */
1287         0                   /* 17 SIGUSR2  */
1288     };
1289
1290 #if __VMS_VER >= 60200000
1291     static int initted = 0;
1292     if (!initted) {
1293         initted = 1;
1294         sig_code[16] = C$_SIGUSR1;
1295         sig_code[17] = C$_SIGUSR2;
1296     }
1297 #endif
1298
1299     if (sig < _SIG_MIN) return 0;
1300     if (sig > _MY_SIG_MAX) return 0;
1301     return sig_code[sig];
1302 }
1303
1304
1305 int
1306 Perl_my_kill(int pid, int sig)
1307 {
1308     dTHX;
1309     int iss;
1310     unsigned int code;
1311     int sys$sigprc(unsigned int *pidadr,
1312                      struct dsc$descriptor_s *prcname,
1313                      unsigned int code);
1314
1315     code = Perl_sig_to_vmscondition(sig);
1316
1317     if (!pid || !code) {
1318         return -1;
1319     }
1320
1321     iss = sys$sigprc((unsigned int *)&pid,0,code);
1322     if (iss&1) return 0;
1323
1324     switch (iss) {
1325       case SS$_NOPRIV:
1326         set_errno(EPERM);  break;
1327       case SS$_NONEXPR:
1328       case SS$_NOSUCHNODE:
1329       case SS$_UNREACHABLE:
1330         set_errno(ESRCH);  break;
1331       case SS$_INSFMEM:
1332         set_errno(ENOMEM); break;
1333       default:
1334         _ckvmssts(iss);
1335         set_errno(EVMSERR);
1336     }
1337     set_vaxc_errno(iss);
1338
1339     return -1;
1340 }
1341 #endif
1342
1343 /* default piping mailbox size */
1344 #define PERL_BUFSIZ        512
1345
1346
1347 static void
1348 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1349 {
1350   unsigned long int mbxbufsiz;
1351   static unsigned long int syssize = 0;
1352   unsigned long int dviitm = DVI$_DEVNAM;
1353   char csize[LNM$C_NAMLENGTH+1];
1354
1355   if (!syssize) {
1356     unsigned long syiitm = SYI$_MAXBUF;
1357     /*
1358      * Get the SYSGEN parameter MAXBUF
1359      *
1360      * If the logical 'PERL_MBX_SIZE' is defined
1361      * use the value of the logical instead of PERL_BUFSIZ, but
1362      * keep the size between 128 and MAXBUF.
1363      *
1364      */
1365     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1366   }
1367
1368   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1369       mbxbufsiz = atoi(csize);
1370   } else {
1371       mbxbufsiz = PERL_BUFSIZ;
1372   }
1373   if (mbxbufsiz < 128) mbxbufsiz = 128;
1374   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1375
1376   _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1377
1378   _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1379   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1380
1381 }  /* end of create_mbx() */
1382
1383
1384 /*{{{  my_popen and my_pclose*/
1385
1386 typedef struct _iosb           IOSB;
1387 typedef struct _iosb*         pIOSB;
1388 typedef struct _pipe           Pipe;
1389 typedef struct _pipe*         pPipe;
1390 typedef struct pipe_details    Info;
1391 typedef struct pipe_details*  pInfo;
1392 typedef struct _srqp            RQE;
1393 typedef struct _srqp*          pRQE;
1394 typedef struct _tochildbuf      CBuf;
1395 typedef struct _tochildbuf*    pCBuf;
1396
1397 struct _iosb {
1398     unsigned short status;
1399     unsigned short count;
1400     unsigned long  dvispec;
1401 };
1402
1403 #pragma member_alignment save
1404 #pragma nomember_alignment quadword
1405 struct _srqp {          /* VMS self-relative queue entry */
1406     unsigned long qptr[2];
1407 };
1408 #pragma member_alignment restore
1409 static RQE  RQE_ZERO = {0,0};
1410
1411 struct _tochildbuf {
1412     RQE             q;
1413     int             eof;
1414     unsigned short  size;
1415     char            *buf;
1416 };
1417
1418 struct _pipe {
1419     RQE            free;
1420     RQE            wait;
1421     int            fd_out;
1422     unsigned short chan_in;
1423     unsigned short chan_out;
1424     char          *buf;
1425     unsigned int   bufsize;
1426     IOSB           iosb;
1427     IOSB           iosb2;
1428     int           *pipe_done;
1429     int            retry;
1430     int            type;
1431     int            shut_on_empty;
1432     int            need_wake;
1433     pPipe         *home;
1434     pInfo          info;
1435     pCBuf          curr;
1436     pCBuf          curr2;
1437 #if defined(PERL_IMPLICIT_CONTEXT)
1438     void            *thx;           /* Either a thread or an interpreter */
1439                                     /* pointer, depending on how we're built */
1440 #endif
1441 };
1442
1443
1444 struct pipe_details
1445 {
1446     pInfo           next;
1447     PerlIO *fp;  /* file pointer to pipe mailbox */
1448     int useFILE; /* using stdio, not perlio */
1449     int pid;   /* PID of subprocess */
1450     int mode;  /* == 'r' if pipe open for reading */
1451     int done;  /* subprocess has completed */
1452     int waiting; /* waiting for completion/closure */
1453     int             closing;        /* my_pclose is closing this pipe */
1454     unsigned long   completion;     /* termination status of subprocess */
1455     pPipe           in;             /* pipe in to sub */
1456     pPipe           out;            /* pipe out of sub */
1457     pPipe           err;            /* pipe of sub's sys$error */
1458     int             in_done;        /* true when in pipe finished */
1459     int             out_done;
1460     int             err_done;
1461 };
1462
1463 struct exit_control_block
1464 {
1465     struct exit_control_block *flink;
1466     unsigned long int   (*exit_routine)();
1467     unsigned long int arg_count;
1468     unsigned long int *status_address;
1469     unsigned long int exit_status;
1470 };
1471
1472 typedef struct _closed_pipes    Xpipe;
1473 typedef struct _closed_pipes*  pXpipe;
1474
1475 struct _closed_pipes {
1476     int             pid;            /* PID of subprocess */
1477     unsigned long   completion;     /* termination status of subprocess */
1478 };
1479 #define NKEEPCLOSED 50
1480 static Xpipe closed_list[NKEEPCLOSED];
1481 static int   closed_index = 0;
1482 static int   closed_num = 0;
1483
1484 #define RETRY_DELAY     "0 ::0.20"
1485 #define MAX_RETRY              50
1486
1487 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
1488 static unsigned long mypid;
1489 static unsigned long delaytime[2];
1490
1491 static pInfo open_pipes = NULL;
1492 static $DESCRIPTOR(nl_desc, "NL:");
1493
1494 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
1495
1496
1497
1498 static unsigned long int
1499 pipe_exit_routine(pTHX)
1500 {
1501     pInfo info;
1502     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1503     int sts, did_stuff, need_eof, j;
1504
1505     /*
1506         flush any pending i/o
1507     */
1508     info = open_pipes;
1509     while (info) {
1510         if (info->fp) {
1511            if (!info->useFILE)
1512                PerlIO_flush(info->fp);   /* first, flush data */
1513            else
1514                fflush((FILE *)info->fp);
1515         }
1516         info = info->next;
1517     }
1518
1519     /*
1520      next we try sending an EOF...ignore if doesn't work, make sure we
1521      don't hang
1522     */
1523     did_stuff = 0;
1524     info = open_pipes;
1525
1526     while (info) {
1527       int need_eof;
1528       _ckvmssts(sys$setast(0));
1529       if (info->in && !info->in->shut_on_empty) {
1530         _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1531                           0, 0, 0, 0, 0, 0));
1532         info->waiting = 1;
1533         did_stuff = 1;
1534       }
1535       _ckvmssts(sys$setast(1));
1536       info = info->next;
1537     }
1538
1539     /* wait for EOF to have effect, up to ~ 30 sec [default] */
1540
1541     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1542         int nwait = 0;
1543
1544         info = open_pipes;
1545         while (info) {
1546           _ckvmssts(sys$setast(0));
1547           if (info->waiting && info->done)
1548                 info->waiting = 0;
1549           nwait += info->waiting;
1550           _ckvmssts(sys$setast(1));
1551           info = info->next;
1552         }
1553         if (!nwait) break;
1554         sleep(1);
1555     }
1556
1557     did_stuff = 0;
1558     info = open_pipes;
1559     while (info) {
1560       _ckvmssts(sys$setast(0));
1561       if (!info->done) { /* Tap them gently on the shoulder . . .*/
1562         sts = sys$forcex(&info->pid,0,&abort);
1563         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1564         did_stuff = 1;
1565       }
1566       _ckvmssts(sys$setast(1));
1567       info = info->next;
1568     }
1569
1570     /* again, wait for effect */
1571
1572     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1573         int nwait = 0;
1574
1575         info = open_pipes;
1576         while (info) {
1577           _ckvmssts(sys$setast(0));
1578           if (info->waiting && info->done)
1579                 info->waiting = 0;
1580           nwait += info->waiting;
1581           _ckvmssts(sys$setast(1));
1582           info = info->next;
1583         }
1584         if (!nwait) break;
1585         sleep(1);
1586     }
1587
1588     info = open_pipes;
1589     while (info) {
1590       _ckvmssts(sys$setast(0));
1591       if (!info->done) {  /* We tried to be nice . . . */
1592         sts = sys$delprc(&info->pid,0);
1593         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1594       }
1595       _ckvmssts(sys$setast(1));
1596       info = info->next;
1597     }
1598
1599     while(open_pipes) {
1600       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1601       else if (!(sts & 1)) retsts = sts;
1602     }
1603     return retsts;
1604 }
1605
1606 static struct exit_control_block pipe_exitblock =
1607        {(struct exit_control_block *) 0,
1608         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1609
1610 static void pipe_mbxtofd_ast(pPipe p);
1611 static void pipe_tochild1_ast(pPipe p);
1612 static void pipe_tochild2_ast(pPipe p);
1613
1614 static void
1615 popen_completion_ast(pInfo info)
1616 {
1617   pInfo i = open_pipes;
1618   int iss;
1619   pXpipe x;
1620
1621   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1622   closed_list[closed_index].pid = info->pid;
1623   closed_list[closed_index].completion = info->completion;
1624   closed_index++;
1625   if (closed_index == NKEEPCLOSED)
1626     closed_index = 0;
1627   closed_num++;
1628
1629   while (i) {
1630     if (i == info) break;
1631     i = i->next;
1632   }
1633   if (!i) return;       /* unlinked, probably freed too */
1634
1635   info->done = TRUE;
1636
1637 /*
1638     Writing to subprocess ...
1639             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1640
1641             chan_out may be waiting for "done" flag, or hung waiting
1642             for i/o completion to child...cancel the i/o.  This will
1643             put it into "snarf mode" (done but no EOF yet) that discards
1644             input.
1645
1646     Output from subprocess (stdout, stderr) needs to be flushed and
1647     shut down.   We try sending an EOF, but if the mbx is full the pipe
1648     routine should still catch the "shut_on_empty" flag, telling it to
1649     use immediate-style reads so that "mbx empty" -> EOF.
1650
1651
1652 */
1653   if (info->in && !info->in_done) {               /* only for mode=w */
1654         if (info->in->shut_on_empty && info->in->need_wake) {
1655             info->in->need_wake = FALSE;
1656             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1657         } else {
1658             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1659         }
1660   }
1661
1662   if (info->out && !info->out_done) {             /* were we also piping output? */
1663       info->out->shut_on_empty = TRUE;
1664       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1665       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1666       _ckvmssts_noperl(iss);
1667   }
1668
1669   if (info->err && !info->err_done) {        /* we were piping stderr */
1670         info->err->shut_on_empty = TRUE;
1671         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1672         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1673         _ckvmssts_noperl(iss);
1674   }
1675   _ckvmssts_noperl(sys$setef(pipe_ef));
1676
1677 }
1678
1679 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
1680 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
1681
1682 /*
1683     we actually differ from vmstrnenv since we use this to
1684     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1685     are pointing to the same thing
1686 */
1687
1688 static unsigned short
1689 popen_translate(pTHX_ char *logical, char *result)
1690 {
1691     int iss;
1692     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1693     $DESCRIPTOR(d_log,"");
1694     struct _il3 {
1695         unsigned short length;
1696         unsigned short code;
1697         char *         buffer_addr;
1698         unsigned short *retlenaddr;
1699     } itmlst[2];
1700     unsigned short l, ifi;
1701
1702     d_log.dsc$a_pointer = logical;
1703     d_log.dsc$w_length  = strlen(logical);
1704
1705     itmlst[0].code = LNM$_STRING;
1706     itmlst[0].length = 255;
1707     itmlst[0].buffer_addr = result;
1708     itmlst[0].retlenaddr = &l;
1709
1710     itmlst[1].code = 0;
1711     itmlst[1].length = 0;
1712     itmlst[1].buffer_addr = 0;
1713     itmlst[1].retlenaddr = 0;
1714
1715     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1716     if (iss == SS$_NOLOGNAM) {
1717         iss = SS$_NORMAL;
1718         l = 0;
1719     }
1720     if (!(iss&1)) lib$signal(iss);
1721     result[l] = '\0';
1722 /*
1723     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
1724     strip it off and return the ifi, if any
1725 */
1726     ifi  = 0;
1727     if (result[0] == 0x1b && result[1] == 0x00) {
1728         memcpy(&ifi,result+2,2);
1729         strcpy(result,result+4);
1730     }
1731     return ifi;     /* this is the RMS internal file id */
1732 }
1733
1734 static void pipe_infromchild_ast(pPipe p);
1735
1736 /*
1737     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1738     inside an AST routine without worrying about reentrancy and which Perl
1739     memory allocator is being used.
1740
1741     We read data and queue up the buffers, then spit them out one at a
1742     time to the output mailbox when the output mailbox is ready for one.
1743
1744 */
1745 #define INITIAL_TOCHILDQUEUE  2
1746
1747 static pPipe
1748 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1749 {
1750     pPipe p;
1751     pCBuf b;
1752     char mbx1[64], mbx2[64];
1753     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1754                                       DSC$K_CLASS_S, mbx1},
1755                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1756                                       DSC$K_CLASS_S, mbx2};
1757     unsigned int dviitm = DVI$_DEVBUFSIZ;
1758     int j, n;
1759
1760     New(1368, p, 1, Pipe);
1761
1762     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1763     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1764     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1765
1766     p->buf           = 0;
1767     p->shut_on_empty = FALSE;
1768     p->need_wake     = FALSE;
1769     p->type          = 0;
1770     p->retry         = 0;
1771     p->iosb.status   = SS$_NORMAL;
1772     p->iosb2.status  = SS$_NORMAL;
1773     p->free          = RQE_ZERO;
1774     p->wait          = RQE_ZERO;
1775     p->curr          = 0;
1776     p->curr2         = 0;
1777     p->info          = 0;
1778 #ifdef PERL_IMPLICIT_CONTEXT
1779     p->thx           = aTHX;
1780 #endif
1781
1782     n = sizeof(CBuf) + p->bufsize;
1783
1784     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1785         _ckvmssts(lib$get_vm(&n, &b));
1786         b->buf = (char *) b + sizeof(CBuf);
1787         _ckvmssts(lib$insqhi(b, &p->free));
1788     }
1789
1790     pipe_tochild2_ast(p);
1791     pipe_tochild1_ast(p);
1792     strcpy(wmbx, mbx1);
1793     strcpy(rmbx, mbx2);
1794     return p;
1795 }
1796
1797 /*  reads the MBX Perl is writing, and queues */
1798
1799 static void
1800 pipe_tochild1_ast(pPipe p)
1801 {
1802     pCBuf b = p->curr;
1803     int iss = p->iosb.status;
1804     int eof = (iss == SS$_ENDOFFILE);
1805 #ifdef PERL_IMPLICIT_CONTEXT
1806     pTHX = p->thx;
1807 #endif
1808
1809     if (p->retry) {
1810         if (eof) {
1811             p->shut_on_empty = TRUE;
1812             b->eof     = TRUE;
1813             _ckvmssts(sys$dassgn(p->chan_in));
1814         } else  {
1815             _ckvmssts(iss);
1816         }
1817
1818         b->eof  = eof;
1819         b->size = p->iosb.count;
1820         _ckvmssts(lib$insqhi(b, &p->wait));
1821         if (p->need_wake) {
1822             p->need_wake = FALSE;
1823             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1824         }
1825     } else {
1826         p->retry = 1;   /* initial call */
1827     }
1828
1829     if (eof) {                  /* flush the free queue, return when done */
1830         int n = sizeof(CBuf) + p->bufsize;
1831         while (1) {
1832             iss = lib$remqti(&p->free, &b);
1833             if (iss == LIB$_QUEWASEMP) return;
1834             _ckvmssts(iss);
1835             _ckvmssts(lib$free_vm(&n, &b));
1836         }
1837     }
1838
1839     iss = lib$remqti(&p->free, &b);
1840     if (iss == LIB$_QUEWASEMP) {
1841         int n = sizeof(CBuf) + p->bufsize;
1842         _ckvmssts(lib$get_vm(&n, &b));
1843         b->buf = (char *) b + sizeof(CBuf);
1844     } else {
1845        _ckvmssts(iss);
1846     }
1847
1848     p->curr = b;
1849     iss = sys$qio(0,p->chan_in,
1850              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1851              &p->iosb,
1852              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1853     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1854     _ckvmssts(iss);
1855 }
1856
1857
1858 /* writes queued buffers to output, waits for each to complete before
1859    doing the next */
1860
1861 static void
1862 pipe_tochild2_ast(pPipe p)
1863 {
1864     pCBuf b = p->curr2;
1865     int iss = p->iosb2.status;
1866     int n = sizeof(CBuf) + p->bufsize;
1867     int done = (p->info && p->info->done) ||
1868               iss == SS$_CANCEL || iss == SS$_ABORT;
1869 #if defined(PERL_IMPLICIT_CONTEXT)
1870     pTHX = p->thx;
1871 #endif
1872
1873     do {
1874         if (p->type) {         /* type=1 has old buffer, dispose */
1875             if (p->shut_on_empty) {
1876                 _ckvmssts(lib$free_vm(&n, &b));
1877             } else {
1878                 _ckvmssts(lib$insqhi(b, &p->free));
1879             }
1880             p->type = 0;
1881         }
1882
1883         iss = lib$remqti(&p->wait, &b);
1884         if (iss == LIB$_QUEWASEMP) {
1885             if (p->shut_on_empty) {
1886                 if (done) {
1887                     _ckvmssts(sys$dassgn(p->chan_out));
1888                     *p->pipe_done = TRUE;
1889                     _ckvmssts(sys$setef(pipe_ef));
1890                 } else {
1891                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1892                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1893                 }
1894                 return;
1895             }
1896             p->need_wake = TRUE;
1897             return;
1898         }
1899         _ckvmssts(iss);
1900         p->type = 1;
1901     } while (done);
1902
1903
1904     p->curr2 = b;
1905     if (b->eof) {
1906         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1907             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1908     } else {
1909         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1910             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1911     }
1912
1913     return;
1914
1915 }
1916
1917
1918 static pPipe
1919 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1920 {
1921     pPipe p;
1922     char mbx1[64], mbx2[64];
1923     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1924                                       DSC$K_CLASS_S, mbx1},
1925                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1926                                       DSC$K_CLASS_S, mbx2};
1927     unsigned int dviitm = DVI$_DEVBUFSIZ;
1928
1929     New(1367, p, 1, Pipe);
1930     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1931     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1932
1933     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1934     New(1367, p->buf, p->bufsize, char);
1935     p->shut_on_empty = FALSE;
1936     p->info   = 0;
1937     p->type   = 0;
1938     p->iosb.status = SS$_NORMAL;
1939 #if defined(PERL_IMPLICIT_CONTEXT)
1940     p->thx = aTHX;
1941 #endif
1942     pipe_infromchild_ast(p);
1943
1944     strcpy(wmbx, mbx1);
1945     strcpy(rmbx, mbx2);
1946     return p;
1947 }
1948
1949 static void
1950 pipe_infromchild_ast(pPipe p)
1951 {
1952     int iss = p->iosb.status;
1953     int eof = (iss == SS$_ENDOFFILE);
1954     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1955     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1956 #if defined(PERL_IMPLICIT_CONTEXT)
1957     pTHX = p->thx;
1958 #endif
1959
1960     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
1961         _ckvmssts(sys$dassgn(p->chan_out));
1962         p->chan_out = 0;
1963     }
1964
1965     /* read completed:
1966             input shutdown if EOF from self (done or shut_on_empty)
1967             output shutdown if closing flag set (my_pclose)
1968             send data/eof from child or eof from self
1969             otherwise, re-read (snarf of data from child)
1970     */
1971
1972     if (p->type == 1) {
1973         p->type = 0;
1974         if (myeof && p->chan_in) {                  /* input shutdown */
1975             _ckvmssts(sys$dassgn(p->chan_in));
1976             p->chan_in = 0;
1977         }
1978
1979         if (p->chan_out) {
1980             if (myeof || kideof) {      /* pass EOF to parent */
1981                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1982                               pipe_infromchild_ast, p,
1983                               0, 0, 0, 0, 0, 0));
1984                 return;
1985             } else if (eof) {       /* eat EOF --- fall through to read*/
1986
1987             } else {                /* transmit data */
1988                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1989                               pipe_infromchild_ast,p,
1990                               p->buf, p->iosb.count, 0, 0, 0, 0));
1991                 return;
1992             }
1993         }
1994     }
1995
1996     /*  everything shut? flag as done */
1997
1998     if (!p->chan_in && !p->chan_out) {
1999         *p->pipe_done = TRUE;
2000         _ckvmssts(sys$setef(pipe_ef));
2001         return;
2002     }
2003
2004     /* write completed (or read, if snarfing from child)
2005             if still have input active,
2006                queue read...immediate mode if shut_on_empty so we get EOF if empty
2007             otherwise,
2008                check if Perl reading, generate EOFs as needed
2009     */
2010
2011     if (p->type == 0) {
2012         p->type = 1;
2013         if (p->chan_in) {
2014             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2015                           pipe_infromchild_ast,p,
2016                           p->buf, p->bufsize, 0, 0, 0, 0);
2017             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2018             _ckvmssts(iss);
2019         } else {           /* send EOFs for extra reads */
2020             p->iosb.status = SS$_ENDOFFILE;
2021             p->iosb.dvispec = 0;
2022             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2023                       0, 0, 0,
2024                       pipe_infromchild_ast, p, 0, 0, 0, 0));
2025         }
2026     }
2027 }
2028
2029 static pPipe
2030 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2031 {
2032     pPipe p;
2033     char mbx[64];
2034     unsigned long dviitm = DVI$_DEVBUFSIZ;
2035     struct stat s;
2036     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2037                                       DSC$K_CLASS_S, mbx};
2038
2039     /* things like terminals and mbx's don't need this filter */
2040     if (fd && fstat(fd,&s) == 0) {
2041         unsigned long dviitm = DVI$_DEVCHAR, devchar;
2042         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2043                                          DSC$K_CLASS_S, s.st_dev};
2044
2045         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2046         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
2047             strcpy(out, s.st_dev);
2048             return 0;
2049         }
2050     }
2051
2052     New(1366, p, 1, Pipe);
2053     p->fd_out = dup(fd);
2054     create_mbx(aTHX_ &p->chan_in, &d_mbx);
2055     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2056     New(1366, p->buf, p->bufsize+1, char);
2057     p->shut_on_empty = FALSE;
2058     p->retry = 0;
2059     p->info  = 0;
2060     strcpy(out, mbx);
2061
2062     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2063                   pipe_mbxtofd_ast, p,
2064                   p->buf, p->bufsize, 0, 0, 0, 0));
2065
2066     return p;
2067 }
2068
2069 static void
2070 pipe_mbxtofd_ast(pPipe p)
2071 {
2072     int iss = p->iosb.status;
2073     int done = p->info->done;
2074     int iss2;
2075     int eof = (iss == SS$_ENDOFFILE);
2076     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2077     int err = !(iss&1) && !eof;
2078 #if defined(PERL_IMPLICIT_CONTEXT)
2079     pTHX = p->thx;
2080 #endif
2081
2082     if (done && myeof) {               /* end piping */
2083         close(p->fd_out);
2084         sys$dassgn(p->chan_in);
2085         *p->pipe_done = TRUE;
2086         _ckvmssts(sys$setef(pipe_ef));
2087         return;
2088     }
2089
2090     if (!err && !eof) {             /* good data to send to file */
2091         p->buf[p->iosb.count] = '\n';
2092         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2093         if (iss2 < 0) {
2094             p->retry++;
2095             if (p->retry < MAX_RETRY) {
2096                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2097                 return;
2098             }
2099         }
2100         p->retry = 0;
2101     } else if (err) {
2102         _ckvmssts(iss);
2103     }
2104
2105
2106     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2107           pipe_mbxtofd_ast, p,
2108           p->buf, p->bufsize, 0, 0, 0, 0);
2109     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2110     _ckvmssts(iss);
2111 }
2112
2113
2114 typedef struct _pipeloc     PLOC;
2115 typedef struct _pipeloc*   pPLOC;
2116
2117 struct _pipeloc {
2118     pPLOC   next;
2119     char    dir[NAM$C_MAXRSS+1];
2120 };
2121 static pPLOC  head_PLOC = 0;
2122
2123 void
2124 free_pipelocs(pTHX_ void *head)
2125 {
2126     pPLOC p, pnext;
2127     pPLOC *pHead = (pPLOC *)head;
2128
2129     p = *pHead;
2130     while (p) {
2131         pnext = p->next;
2132         Safefree(p);
2133         p = pnext;
2134     }
2135     *pHead = 0;
2136 }
2137
2138 static void
2139 store_pipelocs(pTHX)
2140 {
2141     int    i;
2142     pPLOC  p;
2143     AV    *av = 0;
2144     SV    *dirsv;
2145     GV    *gv;
2146     char  *dir, *x;
2147     char  *unixdir;
2148     char  temp[NAM$C_MAXRSS+1];
2149     STRLEN n_a;
2150
2151     if (head_PLOC)
2152         free_pipelocs(aTHX_ &head_PLOC);
2153
2154 /*  the . directory from @INC comes last */
2155
2156     New(1370,p,1,PLOC);
2157     p->next = head_PLOC;
2158     head_PLOC = p;
2159     strcpy(p->dir,"./");
2160
2161 /*  get the directory from $^X */
2162
2163 #ifdef PERL_IMPLICIT_CONTEXT
2164     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2165 #else
2166     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2167 #endif
2168         strcpy(temp, PL_origargv[0]);
2169         x = strrchr(temp,']');
2170         if (x) x[1] = '\0';
2171
2172         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2173             New(1370,p,1,PLOC);
2174             p->next = head_PLOC;
2175             head_PLOC = p;
2176             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2177             p->dir[NAM$C_MAXRSS] = '\0';
2178         }
2179     }
2180
2181 /*  reverse order of @INC entries, skip "." since entered above */
2182
2183 #ifdef PERL_IMPLICIT_CONTEXT
2184     if (aTHX)
2185 #endif
2186     if (PL_incgv) av = GvAVn(PL_incgv);
2187
2188     for (i = 0; av && i <= AvFILL(av); i++) {
2189         dirsv = *av_fetch(av,i,TRUE);
2190
2191         if (SvROK(dirsv)) continue;
2192         dir = SvPVx(dirsv,n_a);
2193         if (strcmp(dir,".") == 0) continue;
2194         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2195             continue;
2196
2197         New(1370,p,1,PLOC);
2198         p->next = head_PLOC;
2199         head_PLOC = p;
2200         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2201         p->dir[NAM$C_MAXRSS] = '\0';
2202     }
2203
2204 /* most likely spot (ARCHLIB) put first in the list */
2205
2206 #ifdef ARCHLIB_EXP
2207     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2208         New(1370,p,1,PLOC);
2209         p->next = head_PLOC;
2210         head_PLOC = p;
2211         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2212         p->dir[NAM$C_MAXRSS] = '\0';
2213     }
2214 #endif
2215 }
2216
2217
2218 static char *
2219 find_vmspipe(pTHX)
2220 {
2221     static int   vmspipe_file_status = 0;
2222     static char  vmspipe_file[NAM$C_MAXRSS+1];
2223
2224     /* already found? Check and use ... need read+execute permission */
2225
2226     if (vmspipe_file_status == 1) {
2227         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2228          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2229             return vmspipe_file;
2230         }
2231         vmspipe_file_status = 0;
2232     }
2233
2234     /* scan through stored @INC, $^X */
2235
2236     if (vmspipe_file_status == 0) {
2237         char file[NAM$C_MAXRSS+1];
2238         pPLOC  p = head_PLOC;
2239
2240         while (p) {
2241             strcpy(file, p->dir);
2242             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2243             file[NAM$C_MAXRSS] = '\0';
2244             p = p->next;
2245
2246             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2247
2248             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2249              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2250                 vmspipe_file_status = 1;
2251                 return vmspipe_file;
2252             }
2253         }
2254         vmspipe_file_status = -1;   /* failed, use tempfiles */
2255     }
2256
2257     return 0;
2258 }
2259
2260 static FILE *
2261 vmspipe_tempfile(pTHX)
2262 {
2263     char file[NAM$C_MAXRSS+1];
2264     FILE *fp;
2265     static int index = 0;
2266     stat_t s0, s1;
2267
2268     /* create a tempfile */
2269
2270     /* we can't go from   W, shr=get to  R, shr=get without
2271        an intermediate vulnerable state, so don't bother trying...
2272
2273        and lib$spawn doesn't shr=put, so have to close the write
2274
2275        So... match up the creation date/time and the FID to
2276        make sure we're dealing with the same file
2277
2278     */
2279
2280     index++;
2281     sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2282     fp = fopen(file,"w");
2283     if (!fp) {
2284         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2285         fp = fopen(file,"w");
2286         if (!fp) {
2287             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2288             fp = fopen(file,"w");
2289         }
2290     }
2291     if (!fp) return 0;  /* we're hosed */
2292
2293     fprintf(fp,"$! 'f$verify(0)'\n");
2294     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
2295     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
2296     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2297     fprintf(fp,"$ perl_on     = \"set noon\"\n");
2298     fprintf(fp,"$ perl_exit   = \"exit\"\n");
2299     fprintf(fp,"$ perl_del    = \"delete\"\n");
2300     fprintf(fp,"$ pif         = \"if\"\n");
2301     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
2302     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
2303     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
2304     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
2305     fprintf(fp,"$!  --- build command line to get max possible length\n");
2306     fprintf(fp,"$c=perl_popen_cmd0\n");
2307     fprintf(fp,"$c=c+perl_popen_cmd1\n");
2308     fprintf(fp,"$c=c+perl_popen_cmd2\n");
2309     fprintf(fp,"$x=perl_popen_cmd3\n");
2310     fprintf(fp,"$c=c+x\n");
2311     fprintf(fp,"$ perl_on\n");
2312     fprintf(fp,"$ 'c'\n");
2313     fprintf(fp,"$ perl_status = $STATUS\n");
2314     fprintf(fp,"$ perl_del  'perl_cfile'\n");
2315     fprintf(fp,"$ perl_exit 'perl_status'\n");
2316     fsync(fileno(fp));
2317
2318     fgetname(fp, file, 1);
2319     fstat(fileno(fp), &s0);
2320     fclose(fp);
2321
2322     fp = fopen(file,"r","shr=get");
2323     if (!fp) return 0;
2324     fstat(fileno(fp), &s1);
2325
2326     if (s0.st_ino[0] != s1.st_ino[0] ||
2327         s0.st_ino[1] != s1.st_ino[1] ||
2328         s0.st_ino[2] != s1.st_ino[2] ||
2329         s0.st_ctime  != s1.st_ctime  )  {
2330         fclose(fp);
2331         return 0;
2332     }
2333
2334     return fp;
2335 }
2336
2337
2338
2339 static PerlIO *
2340 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2341 {
2342     static int handler_set_up = FALSE;
2343     unsigned long int sts, flags = CLI$M_NOWAIT;
2344     /* The use of a GLOBAL table (as was done previously) rendered
2345      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
2346      * environment.  Hence we've switched to LOCAL symbol table.
2347      */
2348     unsigned int table = LIB$K_CLI_LOCAL_SYM;
2349     int j, wait = 0;
2350     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2351     char in[512], out[512], err[512], mbx[512];
2352     FILE *tpipe = 0;
2353     char tfilebuf[NAM$C_MAXRSS+1];
2354     pInfo info;
2355     char cmd_sym_name[20];
2356     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2357                                       DSC$K_CLASS_S, symbol};
2358     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2359                                       DSC$K_CLASS_S, 0};
2360     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2361                                       DSC$K_CLASS_S, cmd_sym_name};
2362     struct dsc$descriptor_s *vmscmd;
2363     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2364     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2365     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2366
2367     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
2368
2369     /* once-per-program initialization...
2370        note that the SETAST calls and the dual test of pipe_ef
2371        makes sure that only the FIRST thread through here does
2372        the initialization...all other threads wait until it's
2373        done.
2374
2375        Yeah, uglier than a pthread call, it's got all the stuff inline
2376        rather than in a separate routine.
2377     */
2378
2379     if (!pipe_ef) {
2380         _ckvmssts(sys$setast(0));
2381         if (!pipe_ef) {
2382             unsigned long int pidcode = JPI$_PID;
2383             $DESCRIPTOR(d_delay, RETRY_DELAY);
2384             _ckvmssts(lib$get_ef(&pipe_ef));
2385             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2386             _ckvmssts(sys$bintim(&d_delay, delaytime));
2387         }
2388         if (!handler_set_up) {
2389           _ckvmssts(sys$dclexh(&pipe_exitblock));
2390           handler_set_up = TRUE;
2391         }
2392         _ckvmssts(sys$setast(1));
2393     }
2394
2395     /* see if we can find a VMSPIPE.COM */
2396
2397     tfilebuf[0] = '@';
2398     vmspipe = find_vmspipe(aTHX);
2399     if (vmspipe) {
2400         strcpy(tfilebuf+1,vmspipe);
2401     } else {        /* uh, oh...we're in tempfile hell */
2402         tpipe = vmspipe_tempfile(aTHX);
2403         if (!tpipe) {       /* a fish popular in Boston */
2404             if (ckWARN(WARN_PIPE)) {
2405                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
2406             }
2407         return Nullfp;
2408         }
2409         fgetname(tpipe,tfilebuf+1,1);
2410     }
2411     vmspipedsc.dsc$a_pointer = tfilebuf;
2412     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
2413
2414     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
2415     if (!(sts & 1)) {
2416       switch (sts) {
2417         case RMS$_FNF:  case RMS$_DNF:
2418           set_errno(ENOENT); break;
2419         case RMS$_DIR:
2420           set_errno(ENOTDIR); break;
2421         case RMS$_DEV:
2422           set_errno(ENODEV); break;
2423         case RMS$_PRV:
2424           set_errno(EACCES); break;
2425         case RMS$_SYN:
2426           set_errno(EINVAL); break;
2427         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2428           set_errno(E2BIG); break;
2429         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2430           _ckvmssts(sts); /* fall through */
2431         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2432           set_errno(EVMSERR);
2433       }
2434       set_vaxc_errno(sts);
2435       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2436         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2437       }
2438       *psts = sts;
2439       return Nullfp;
2440     }
2441     New(1301,info,1,Info);
2442
2443     strcpy(mode,in_mode);
2444     info->mode = *mode;
2445     info->done = FALSE;
2446     info->completion = 0;
2447     info->closing    = FALSE;
2448     info->in         = 0;
2449     info->out        = 0;
2450     info->err        = 0;
2451     info->fp         = Nullfp;
2452     info->useFILE    = 0;
2453     info->waiting    = 0;
2454     info->in_done    = TRUE;
2455     info->out_done   = TRUE;
2456     info->err_done   = TRUE;
2457     in[0] = out[0] = err[0] = '\0';
2458
2459     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
2460         info->useFILE = 1;
2461         strcpy(p,p+1);
2462     }
2463     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
2464         wait = 1;
2465         strcpy(p,p+1);
2466     }
2467
2468     if (*mode == 'r') {             /* piping from subroutine */
2469
2470         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2471         if (info->out) {
2472             info->out->pipe_done = &info->out_done;
2473             info->out_done = FALSE;
2474             info->out->info = info;
2475         }
2476         if (!info->useFILE) {
2477         info->fp  = PerlIO_open(mbx, mode);
2478         } else {
2479             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2480             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2481         }
2482
2483         if (!info->fp && info->out) {
2484             sys$cancel(info->out->chan_out);
2485
2486             while (!info->out_done) {
2487                 int done;
2488                 _ckvmssts(sys$setast(0));
2489                 done = info->out_done;
2490                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2491                 _ckvmssts(sys$setast(1));
2492                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2493             }
2494
2495             if (info->out->buf) Safefree(info->out->buf);
2496             Safefree(info->out);
2497             Safefree(info);
2498             *psts = RMS$_FNF;
2499             return Nullfp;
2500         }
2501
2502         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2503         if (info->err) {
2504             info->err->pipe_done = &info->err_done;
2505             info->err_done = FALSE;
2506             info->err->info = info;
2507         }
2508
2509     } else if (*mode == 'w') {      /* piping to subroutine */
2510
2511         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2512         if (info->out) {
2513             info->out->pipe_done = &info->out_done;
2514             info->out_done = FALSE;
2515             info->out->info = info;
2516         }
2517
2518         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2519         if (info->err) {
2520             info->err->pipe_done = &info->err_done;
2521             info->err_done = FALSE;
2522             info->err->info = info;
2523         }
2524
2525         info->in = pipe_tochild_setup(aTHX_ in,mbx);
2526         if (!info->useFILE) {
2527         info->fp  = PerlIO_open(mbx, mode);
2528         } else {
2529             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2530             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2531         }
2532
2533         if (info->in) {
2534             info->in->pipe_done = &info->in_done;
2535             info->in_done = FALSE;
2536             info->in->info = info;
2537         }
2538
2539         /* error cleanup */
2540         if (!info->fp && info->in) {
2541             info->done = TRUE;
2542             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2543                               0, 0, 0, 0, 0, 0, 0, 0));
2544
2545             while (!info->in_done) {
2546                 int done;
2547                 _ckvmssts(sys$setast(0));
2548                 done = info->in_done;
2549                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2550                 _ckvmssts(sys$setast(1));
2551                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2552             }
2553
2554             if (info->in->buf) Safefree(info->in->buf);
2555             Safefree(info->in);
2556             Safefree(info);
2557             *psts = RMS$_FNF;
2558             return Nullfp;
2559         }
2560
2561
2562     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
2563         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2564         if (info->out) {
2565             info->out->pipe_done = &info->out_done;
2566             info->out_done = FALSE;
2567             info->out->info = info;
2568         }
2569
2570         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2571         if (info->err) {
2572             info->err->pipe_done = &info->err_done;
2573             info->err_done = FALSE;
2574             info->err->info = info;
2575         }
2576     }
2577
2578     symbol[MAX_DCL_SYMBOL] = '\0';
2579
2580     strncpy(symbol, in, MAX_DCL_SYMBOL);
2581     d_symbol.dsc$w_length = strlen(symbol);
2582     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2583
2584     strncpy(symbol, err, MAX_DCL_SYMBOL);
2585     d_symbol.dsc$w_length = strlen(symbol);
2586     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2587
2588     strncpy(symbol, out, MAX_DCL_SYMBOL);
2589     d_symbol.dsc$w_length = strlen(symbol);
2590     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2591
2592     p = vmscmd->dsc$a_pointer;
2593     while (*p && *p != '\n') p++;
2594     *p = '\0';                                  /* truncate on \n */
2595     p = vmscmd->dsc$a_pointer;
2596     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
2597     if (*p == '$') p++;                         /* remove leading $ */
2598     while (*p == ' ' || *p == '\t') p++;
2599
2600     for (j = 0; j < 4; j++) {
2601         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2602         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2603
2604     strncpy(symbol, p, MAX_DCL_SYMBOL);
2605     d_symbol.dsc$w_length = strlen(symbol);
2606     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2607
2608         if (strlen(p) > MAX_DCL_SYMBOL) {
2609             p += MAX_DCL_SYMBOL;
2610         } else {
2611             p += strlen(p);
2612         }
2613     }
2614     _ckvmssts(sys$setast(0));
2615     info->next=open_pipes;  /* prepend to list */
2616     open_pipes=info;
2617     _ckvmssts(sys$setast(1));
2618     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
2619      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
2620      * have SYS$COMMAND if we need it.
2621      */
2622     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
2623                       0, &info->pid, &info->completion,
2624                       0, popen_completion_ast,info,0,0,0));
2625
2626     /* if we were using a tempfile, close it now */
2627
2628     if (tpipe) fclose(tpipe);
2629
2630     /* once the subprocess is spawned, it has copied the symbols and
2631        we can get rid of ours */
2632
2633     for (j = 0; j < 4; j++) {
2634         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2635         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2636     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2637     }
2638     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
2639     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2640     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2641     vms_execfree(vmscmd);
2642
2643 #ifdef PERL_IMPLICIT_CONTEXT
2644     if (aTHX)
2645 #endif
2646     PL_forkprocess = info->pid;
2647
2648     if (wait) {
2649          int done = 0;
2650          while (!done) {
2651              _ckvmssts(sys$setast(0));
2652              done = info->done;
2653              if (!done) _ckvmssts(sys$clref(pipe_ef));
2654              _ckvmssts(sys$setast(1));
2655              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2656          }
2657         *psts = info->completion;
2658         my_pclose(info->fp);
2659     } else {
2660         *psts = SS$_NORMAL;
2661     }
2662     return info->fp;
2663 }  /* end of safe_popen */
2664
2665
2666 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
2667 PerlIO *
2668 Perl_my_popen(pTHX_ char *cmd, char *mode)
2669 {
2670     int sts;
2671     TAINT_ENV();
2672     TAINT_PROPER("popen");
2673     PERL_FLUSHALL_FOR_CHILD;
2674     return safe_popen(aTHX_ cmd,mode,&sts);
2675 }
2676
2677 /*}}}*/
2678
2679 /*{{{  I32 my_pclose(PerlIO *fp)*/
2680 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2681 {
2682     pInfo info, last = NULL;
2683     unsigned long int retsts;
2684     int done, iss;
2685
2686     for (info = open_pipes; info != NULL; last = info, info = info->next)
2687         if (info->fp == fp) break;
2688
2689     if (info == NULL) {  /* no such pipe open */
2690       set_errno(ECHILD); /* quoth POSIX */
2691       set_vaxc_errno(SS$_NONEXPR);
2692       return -1;
2693     }
2694
2695     /* If we were writing to a subprocess, insure that someone reading from
2696      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
2697      * produce an EOF record in the mailbox.
2698      *
2699      *  well, at least sometimes it *does*, so we have to watch out for
2700      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
2701      */
2702      if (info->fp) {
2703         if (!info->useFILE)
2704      PerlIO_flush(info->fp);   /* first, flush data */
2705         else
2706             fflush((FILE *)info->fp);
2707     }
2708
2709     _ckvmssts(sys$setast(0));
2710      info->closing = TRUE;
2711      done = info->done && info->in_done && info->out_done && info->err_done;
2712      /* hanging on write to Perl's input? cancel it */
2713      if (info->mode == 'r' && info->out && !info->out_done) {
2714         if (info->out->chan_out) {
2715             _ckvmssts(sys$cancel(info->out->chan_out));
2716             if (!info->out->chan_in) {   /* EOF generation, need AST */
2717                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2718             }
2719         }
2720      }
2721      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
2722          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2723                            0, 0, 0, 0, 0, 0));
2724     _ckvmssts(sys$setast(1));
2725     if (info->fp) {
2726      if (!info->useFILE)
2727     PerlIO_close(info->fp);
2728      else
2729         fclose((FILE *)info->fp);
2730     }
2731      /*
2732         we have to wait until subprocess completes, but ALSO wait until all
2733         the i/o completes...otherwise we'll be freeing the "info" structure
2734         that the i/o ASTs could still be using...
2735      */
2736
2737      while (!done) {
2738          _ckvmssts(sys$setast(0));
2739          done = info->done && info->in_done && info->out_done && info->err_done;
2740          if (!done) _ckvmssts(sys$clref(pipe_ef));
2741          _ckvmssts(sys$setast(1));
2742          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2743      }
2744      retsts = info->completion;
2745
2746     /* remove from list of open pipes */
2747     _ckvmssts(sys$setast(0));
2748     if (last) last->next = info->next;
2749     else open_pipes = info->next;
2750     _ckvmssts(sys$setast(1));
2751
2752     /* free buffers and structures */
2753
2754     if (info->in) {
2755         if (info->in->buf) Safefree(info->in->buf);
2756         Safefree(info->in);
2757     }
2758     if (info->out) {
2759         if (info->out->buf) Safefree(info->out->buf);
2760         Safefree(info->out);
2761     }
2762     if (info->err) {
2763         if (info->err->buf) Safefree(info->err->buf);
2764         Safefree(info->err);
2765     }
2766     Safefree(info);
2767
2768     return retsts;
2769
2770 }  /* end of my_pclose() */
2771
2772 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
2773   /* Roll our own prototype because we want this regardless of whether
2774    * _VMS_WAIT is defined.
2775    */
2776   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2777 #endif
2778 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2779    created with popen(); otherwise partially emulate waitpid() unless
2780    we have a suitable one from the CRTL that came with VMS 7.2 and later.
2781    Also check processes not considered by the CRTL waitpid().
2782  */
2783 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2784 Pid_t
2785 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2786 {
2787     pInfo info;
2788     int done;
2789     int sts;
2790     int j;
2791
2792     if (statusp) *statusp = 0;
2793
2794     for (info = open_pipes; info != NULL; info = info->next)
2795         if (info->pid == pid) break;
2796
2797     if (info != NULL) {  /* we know about this child */
2798       while (!info->done) {
2799           _ckvmssts(sys$setast(0));
2800           done = info->done;
2801           if (!done) _ckvmssts(sys$clref(pipe_ef));
2802           _ckvmssts(sys$setast(1));
2803           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2804       }
2805
2806       if (statusp) *statusp = info->completion;
2807       return pid;
2808     }
2809
2810     /* child that already terminated? */
2811
2812     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
2813         if (closed_list[j].pid == pid) {
2814             if (statusp) *statusp = closed_list[j].completion;
2815             return pid;
2816         }
2817     }
2818
2819     /* fall through if this child is not one of our own pipe children */
2820
2821 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
2822
2823       /* waitpid() became available in the CRTL as of VMS 7.0, but only
2824        * in 7.2 did we get a version that fills in the VMS completion
2825        * status as Perl has always tried to do.
2826        */
2827
2828       sts = __vms_waitpid( pid, statusp, flags );
2829
2830       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2831          return sts;
2832
2833       /* If the real waitpid tells us the child does not exist, we
2834        * fall through here to implement waiting for a child that
2835        * was created by some means other than exec() (say, spawned
2836        * from DCL) or to wait for a process that is not a subprocess
2837        * of the current process.
2838        */
2839
2840 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
2841
2842     {
2843       $DESCRIPTOR(intdsc,"0 00:00:01");
2844       unsigned long int ownercode = JPI$_OWNER, ownerpid;
2845       unsigned long int pidcode = JPI$_PID, mypid;
2846       unsigned long int interval[2];
2847       unsigned int jpi_iosb[2];
2848       struct itmlst_3 jpilist[2] = {
2849           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
2850           {                      0,         0,                 0, 0}
2851       };
2852
2853       if (pid <= 0) {
2854         /* Sorry folks, we don't presently implement rooting around for
2855            the first child we can find, and we definitely don't want to
2856            pass a pid of -1 to $getjpi, where it is a wildcard operation.
2857          */
2858         set_errno(ENOTSUP);
2859         return -1;
2860       }
2861
2862       /* Get the owner of the child so I can warn if it's not mine. If the
2863        * process doesn't exist or I don't have the privs to look at it,
2864        * I can go home early.
2865        */
2866       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2867       if (sts & 1) sts = jpi_iosb[0];
2868       if (!(sts & 1)) {
2869         switch (sts) {
2870             case SS$_NONEXPR:
2871                 set_errno(ECHILD);
2872                 break;
2873             case SS$_NOPRIV:
2874                 set_errno(EACCES);
2875                 break;
2876             default:
2877                 _ckvmssts(sts);
2878         }
2879         set_vaxc_errno(sts);
2880         return -1;
2881       }
2882
2883       if (ckWARN(WARN_EXEC)) {
2884         /* remind folks they are asking for non-standard waitpid behavior */
2885         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2886         if (ownerpid != mypid)
2887           Perl_warner(aTHX_ packWARN(WARN_EXEC),
2888                       "waitpid: process %x is not a child of process %x",
2889                       pid,mypid);
2890       }
2891
2892       /* simply check on it once a second until it's not there anymore. */
2893
2894       _ckvmssts(sys$bintim(&intdsc,interval));
2895       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2896             _ckvmssts(sys$schdwk(0,0,interval,0));
2897             _ckvmssts(sys$hiber());
2898       }
2899       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2900
2901       _ckvmssts(sts);
2902       return pid;
2903     }
2904 }  /* end of waitpid() */
2905 /*}}}*/
2906 /*}}}*/
2907 /*}}}*/
2908
2909 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2910 char *
2911 my_gconvert(double val, int ndig, int trail, char *buf)
2912 {
2913   static char __gcvtbuf[DBL_DIG+1];
2914   char *loc;
2915
2916   loc = buf ? buf : __gcvtbuf;
2917
2918 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
2919   if (val < 1) {
2920     sprintf(loc,"%.*g",ndig,val);
2921     return loc;
2922   }
2923 #endif
2924
2925   if (val) {
2926     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2927     return gcvt(val,ndig,loc);
2928   }
2929   else {
2930     loc[0] = '0'; loc[1] = '\0';
2931     return loc;
2932   }
2933
2934 }
2935 /*}}}*/
2936
2937
2938 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2939 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2940  * to expand file specification.  Allows for a single default file
2941  * specification and a simple mask of options.  If outbuf is non-NULL,
2942  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2943  * the resultant file specification is placed.  If outbuf is NULL, the
2944  * resultant file specification is placed into a static buffer.
2945  * The third argument, if non-NULL, is taken to be a default file
2946  * specification string.  The fourth argument is unused at present.
2947  * rmesexpand() returns the address of the resultant string if
2948  * successful, and NULL on error.
2949  */
2950 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2951
2952 static char *
2953 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2954 {
2955   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2956   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2957   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2958   struct FAB myfab = cc$rms_fab;
2959   struct NAM mynam = cc$rms_nam;
2960   STRLEN speclen;
2961   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2962
2963   if (!filespec || !*filespec) {
2964     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2965     return NULL;
2966   }
2967   if (!outbuf) {
2968     if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2969     else    outbuf = __rmsexpand_retbuf;
2970   }
2971   if ((isunix = (strchr(filespec,'/') != NULL))) {
2972     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2973     filespec = vmsfspec;
2974   }
2975
2976   myfab.fab$l_fna = filespec;
2977   myfab.fab$b_fns = strlen(filespec);
2978   myfab.fab$l_nam = &mynam;
2979
2980   if (defspec && *defspec) {
2981     if (strchr(defspec,'/') != NULL) {
2982       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2983       defspec = tmpfspec;
2984     }
2985     myfab.fab$l_dna = defspec;
2986     myfab.fab$b_dns = strlen(defspec);
2987   }
2988
2989   mynam.nam$l_esa = esa;
2990   mynam.nam$b_ess = sizeof esa;
2991   mynam.nam$l_rsa = outbuf;
2992   mynam.nam$b_rss = NAM$C_MAXRSS;
2993
2994   retsts = sys$parse(&myfab,0,0);
2995   if (!(retsts & 1)) {
2996     mynam.nam$b_nop |= NAM$M_SYNCHK;
2997     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2998       retsts = sys$parse(&myfab,0,0);
2999       if (retsts & 1) goto expanded;
3000     }
3001     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3002     (void) sys$parse(&myfab,0,0);  /* Free search context */
3003     if (out) Safefree(out);
3004     set_vaxc_errno(retsts);
3005     if      (retsts == RMS$_PRV) set_errno(EACCES);
3006     else if (retsts == RMS$_DEV) set_errno(ENODEV);
3007     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3008     else                         set_errno(EVMSERR);
3009     return NULL;
3010   }
3011   retsts = sys$search(&myfab,0,0);
3012   if (!(retsts & 1) && retsts != RMS$_FNF) {
3013     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3014     myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
3015     if (out) Safefree(out);
3016     set_vaxc_errno(retsts);
3017     if      (retsts == RMS$_PRV) set_errno(EACCES);
3018     else                         set_errno(EVMSERR);
3019     return NULL;
3020   }
3021
3022   /* If the input filespec contained any lowercase characters,
3023    * downcase the result for compatibility with Unix-minded code. */
3024   expanded:
3025   for (out = myfab.fab$l_fna; *out; out++)
3026     if (islower(*out)) { haslower = 1; break; }
3027   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3028   else                 { out = esa;    speclen = mynam.nam$b_esl; }
3029   /* Trim off null fields added by $PARSE
3030    * If type > 1 char, must have been specified in original or default spec
3031    * (not true for version; $SEARCH may have added version of existing file).
3032    */
3033   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3034   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3035              (mynam.nam$l_ver - mynam.nam$l_type == 1);
3036   if (trimver || trimtype) {
3037     if (defspec && *defspec) {
3038       char defesa[NAM$C_MAXRSS];
3039       struct FAB deffab = cc$rms_fab;
3040       struct NAM defnam = cc$rms_nam;
3041
3042       deffab.fab$l_nam = &defnam;
3043       deffab.fab$l_fna = defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
3044       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
3045       defnam.nam$b_nop = NAM$M_SYNCHK;
3046       if (sys$parse(&deffab,0,0) & 1) {
3047         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
3048         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
3049       }
3050     }
3051     if (trimver) speclen = mynam.nam$l_ver - out;
3052     if (trimtype) {
3053       /* If we didn't already trim version, copy down */
3054       if (speclen > mynam.nam$l_ver - out)
3055         memcpy(mynam.nam$l_type, mynam.nam$l_ver,
3056                speclen - (mynam.nam$l_ver - out));
3057       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
3058     }
3059   }
3060   /* If we just had a directory spec on input, $PARSE "helpfully"
3061    * adds an empty name and type for us */
3062   if (mynam.nam$l_name == mynam.nam$l_type &&
3063       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
3064       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
3065     speclen = mynam.nam$l_name - out;
3066   out[speclen] = '\0';
3067   if (haslower) __mystrtolower(out);
3068
3069   /* Have we been working with an expanded, but not resultant, spec? */
3070   /* Also, convert back to Unix syntax if necessary. */
3071   if (!mynam.nam$b_rsl) {
3072     if (isunix) {
3073       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
3074     }
3075     else strcpy(outbuf,esa);
3076   }
3077   else if (isunix) {
3078     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
3079     strcpy(outbuf,tmpfspec);
3080   }
3081   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3082   mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
3083   myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
3084   return outbuf;
3085 }
3086 /*}}}*/
3087 /* External entry points */
3088 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
3089 { return do_rmsexpand(spec,buf,0,def,opt); }
3090 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
3091 { return do_rmsexpand(spec,buf,1,def,opt); }
3092
3093
3094 /*
3095 ** The following routines are provided to make life easier when
3096 ** converting among VMS-style and Unix-style directory specifications.
3097 ** All will take input specifications in either VMS or Unix syntax. On
3098 ** failure, all return NULL.  If successful, the routines listed below
3099 ** return a pointer to a buffer containing the appropriately
3100 ** reformatted spec (and, therefore, subsequent calls to that routine
3101 ** will clobber the result), while the routines of the same names with
3102 ** a _ts suffix appended will return a pointer to a mallocd string
3103 ** containing the appropriately reformatted spec.
3104 ** In all cases, only explicit syntax is altered; no check is made that
3105 ** the resulting string is valid or that the directory in question
3106 ** actually exists.
3107 **
3108 **   fileify_dirspec() - convert a directory spec into the name of the
3109 **     directory file (i.e. what you can stat() to see if it's a dir).
3110 **     The style (VMS or Unix) of the result is the same as the style
3111 **     of the parameter passed in.
3112 **   pathify_dirspec() - convert a directory spec into a path (i.e.
3113 **     what you prepend to a filename to indicate what directory it's in).
3114 **     The style (VMS or Unix) of the result is the same as the style
3115 **     of the parameter passed in.
3116 **   tounixpath() - convert a directory spec into a Unix-style path.
3117 **   tovmspath() - convert a directory spec into a VMS-style path.
3118 **   tounixspec() - convert any file spec into a Unix-style file spec.
3119 **   tovmsspec() - convert any file spec into a VMS-style spec.
3120 **
3121 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
3122 ** Permission is given to distribute this code as part of the Perl
3123 ** standard distribution under the terms of the GNU General Public
3124 ** License or the Perl Artistic License.  Copies of each may be
3125 ** found in the Perl standard distribution.
3126  */
3127
3128 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
3129 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
3130 {
3131     static char __fileify_retbuf[NAM$C_MAXRSS+1];
3132     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
3133     char *retspec, *cp1, *cp2, *lastdir;
3134     char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
3135     unsigned short int trnlnm_iter_count;
3136
3137     if (!dir || !*dir) {
3138       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3139     }
3140     dirlen = strlen(dir);
3141     while (dirlen && dir[dirlen-1] == '/') --dirlen;
3142     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3143       strcpy(trndir,"/sys$disk/000000");
3144       dir = trndir;
3145       dirlen = 16;
3146     }
3147     if (dirlen > NAM$C_MAXRSS) {
3148       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3149     }
3150     if (!strpbrk(dir+1,"/]>:")) {
3151       strcpy(trndir,*dir == '/' ? dir + 1: dir);
3152       trnlnm_iter_count = 0;
3153       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
3154         trnlnm_iter_count++;
3155         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3156       }
3157       dir = trndir;
3158       dirlen = strlen(dir);
3159     }
3160     else {
3161       strncpy(trndir,dir,dirlen);
3162       trndir[dirlen] = '\0';
3163       dir = trndir;
3164     }
3165     /* If we were handed a rooted logical name or spec, treat it like a
3166      * simple directory, so that
3167      *    $ Define myroot dev:[dir.]
3168      *    ... do_fileify_dirspec("myroot",buf,1) ...
3169      * does something useful.
3170      */
3171     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
3172       dir[--dirlen] = '\0';
3173       dir[dirlen-1] = ']';
3174     }
3175     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
3176       dir[--dirlen] = '\0';
3177       dir[dirlen-1] = '>';
3178     }
3179
3180     if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
3181       /* If we've got an explicit filename, we can just shuffle the string. */
3182       if (*(cp1+1)) hasfilename = 1;
3183       /* Similarly, we can just back up a level if we've got multiple levels
3184          of explicit directories in a VMS spec which ends with directories. */
3185       else {
3186         for (cp2 = cp1; cp2 > dir; cp2--) {
3187           if (*cp2 == '.') {
3188             *cp2 = *cp1; *cp1 = '\0';
3189             hasfilename = 1;
3190             break;
3191           }
3192           if (*cp2 == '[' || *cp2 == '<') break;
3193         }
3194       }
3195     }
3196
3197     if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
3198       if (dir[0] == '.') {
3199         if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
3200           return do_fileify_dirspec("[]",buf,ts);
3201         else if (dir[1] == '.' &&
3202                  (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
3203           return do_fileify_dirspec("[-]",buf,ts);
3204       }
3205       if (dirlen && dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
3206         dirlen -= 1;                 /* to last element */
3207         lastdir = strrchr(dir,'/');
3208       }
3209       else if ((cp1 = strstr(dir,"/.")) != NULL) {
3210         /* If we have "/." or "/..", VMSify it and let the VMS code
3211          * below expand it, rather than repeating the code to handle
3212          * relative components of a filespec here */
3213         do {
3214           if (*(cp1+2) == '.') cp1++;
3215           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3216             if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3217             if (strchr(vmsdir,'/') != NULL) {
3218               /* If do_tovmsspec() returned it, it must have VMS syntax
3219                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
3220                * the time to check this here only so we avoid a recursion
3221                * loop; otherwise, gigo.
3222                */
3223               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
3224             }
3225             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3226             return do_tounixspec(trndir,buf,ts);
3227           }
3228           cp1++;
3229         } while ((cp1 = strstr(cp1,"/.")) != NULL);
3230         lastdir = strrchr(dir,'/');
3231       }
3232       else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
3233         /* Ditto for specs that end in an MFD -- let the VMS code
3234          * figure out whether it's a real device or a rooted logical. */
3235         dir[dirlen] = '/'; dir[dirlen+1] = '\0';
3236         if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3237         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3238         return do_tounixspec(trndir,buf,ts);
3239       }
3240       else {
3241         if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
3242              !(lastdir = cp1 = strrchr(dir,']')) &&
3243              !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
3244         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
3245           int ver; char *cp3;
3246           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3247               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3248               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3249               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3250               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3251                             (ver || *cp3)))))) {
3252             set_errno(ENOTDIR);
3253             set_vaxc_errno(RMS$_DIR);
3254             return NULL;
3255           }
3256           dirlen = cp2 - dir;
3257         }
3258       }
3259       /* If we lead off with a device or rooted logical, add the MFD
3260          if we're specifying a top-level directory. */
3261       if (lastdir && *dir == '/') {
3262         addmfd = 1;
3263         for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
3264           if (*cp1 == '/') {
3265             addmfd = 0;
3266             break;
3267           }
3268         }
3269       }
3270       retlen = dirlen + (addmfd ? 13 : 6);
3271       if (buf) retspec = buf;
3272       else if (ts) New(1309,retspec,retlen+1,char);
3273       else retspec = __fileify_retbuf;
3274       if (addmfd) {
3275         dirlen = lastdir - dir;
3276         memcpy(retspec,dir,dirlen);
3277         strcpy(&retspec[dirlen],"/000000");
3278         strcpy(&retspec[dirlen+7],lastdir);
3279       }
3280       else {
3281         memcpy(retspec,dir,dirlen);
3282         retspec[dirlen] = '\0';
3283       }
3284       /* We've picked up everything up to the directory file name.
3285          Now just add the type and version, and we're set. */
3286       strcat(retspec,".dir;1");
3287       return retspec;
3288     }
3289     else {  /* VMS-style directory spec */
3290       char esa[NAM$C_MAXRSS+1], term, *cp;
3291       unsigned long int sts, cmplen, haslower = 0;
3292       struct FAB dirfab = cc$rms_fab;
3293       struct NAM savnam, dirnam = cc$rms_nam;
3294
3295       dirfab.fab$b_fns = strlen(dir);
3296       dirfab.fab$l_fna = dir;
3297       dirfab.fab$l_nam = &dirnam;
3298       dirfab.fab$l_dna = ".DIR;1";
3299       dirfab.fab$b_dns = 6;
3300       dirnam.nam$b_ess = NAM$C_MAXRSS;
3301       dirnam.nam$l_esa = esa;
3302
3303       for (cp = dir; *cp; cp++)
3304         if (islower(*cp)) { haslower = 1; break; }
3305       if (!((sts = sys$parse(&dirfab))&1)) {
3306         if (dirfab.fab$l_sts == RMS$_DIR) {
3307           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3308           sts = sys$parse(&dirfab) & 1;
3309         }
3310         if (!sts) {
3311           set_errno(EVMSERR);
3312           set_vaxc_errno(dirfab.fab$l_sts);
3313           return NULL;
3314         }
3315       }
3316       else {
3317         savnam = dirnam;
3318         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
3319           /* Yes; fake the fnb bits so we'll check type below */
3320           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3321         }
3322         else { /* No; just work with potential name */
3323           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3324           else {
3325             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
3326             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3327             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3328             return NULL;
3329           }
3330         }
3331       }
3332       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3333         cp1 = strchr(esa,']');
3334         if (!cp1) cp1 = strchr(esa,'>');
3335         if (cp1) {  /* Should always be true */
3336           dirnam.nam$b_esl -= cp1 - esa - 1;
3337           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3338         }
3339       }
3340       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3341         /* Yep; check version while we're at it, if it's there. */
3342         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3343         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3344           /* Something other than .DIR[;1].  Bzzt. */
3345           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3346           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3347           set_errno(ENOTDIR);
3348           set_vaxc_errno(RMS$_DIR);
3349           return NULL;
3350         }
3351       }
3352       esa[dirnam.nam$b_esl] = '\0';
3353       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3354         /* They provided at least the name; we added the type, if necessary, */
3355         if (buf) retspec = buf;                            /* in sys$parse() */
3356         else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3357         else retspec = __fileify_retbuf;
3358         strcpy(retspec,esa);
3359         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3360         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3361         return retspec;
3362       }
3363       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3364         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3365         *cp1 = '\0';
3366         dirnam.nam$b_esl -= 9;
3367       }
3368       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3369       if (cp1 == NULL) { /* should never happen */
3370         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3371         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3372         return NULL;
3373       }
3374       term = *cp1;
3375       *cp1 = '\0';
3376       retlen = strlen(esa);
3377       if ((cp1 = strrchr(esa,'.')) != NULL) {
3378         /* There's more than one directory in the path.  Just roll back. */
3379         *cp1 = term;
3380         if (buf) retspec = buf;
3381         else if (ts) New(1311,retspec,retlen+7,char);
3382         else retspec = __fileify_retbuf;
3383         strcpy(retspec,esa);
3384       }
3385       else {
3386         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3387           /* Go back and expand rooted logical name */
3388           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3389           if (!(sys$parse(&dirfab) & 1)) {
3390             dirnam.nam$l_rlf = NULL;
3391             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3392             set_errno(EVMSERR);
3393             set_vaxc_errno(dirfab.fab$l_sts);
3394             return NULL;
3395           }
3396           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3397           if (buf) retspec = buf;
3398           else if (ts) New(1312,retspec,retlen+16,char);
3399           else retspec = __fileify_retbuf;
3400           cp1 = strstr(esa,"][");
3401           if (!cp1) cp1 = strstr(esa,"]<");
3402           dirlen = cp1 - esa;
3403           memcpy(retspec,esa,dirlen);
3404           if (!strncmp(cp1+2,"000000]",7)) {
3405             retspec[dirlen-1] = '\0';
3406             for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3407             if (*cp1 == '.') *cp1 = ']';
3408             else {
3409               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3410               memcpy(cp1+1,"000000]",7);
3411             }
3412           }
3413           else {
3414             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3415             retspec[retlen] = '\0';
3416             /* Convert last '.' to ']' */
3417             for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3418             if (*cp1 == '.') *cp1 = ']';
3419             else {
3420               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3421               memcpy(cp1+1,"000000]",7);
3422             }
3423           }
3424         }
3425         else {  /* This is a top-level dir.  Add the MFD to the path. */
3426           if (buf) retspec = buf;
3427           else if (ts) New(1312,retspec,retlen+16,char);
3428           else retspec = __fileify_retbuf;
3429           cp1 = esa;
3430           cp2 = retspec;
3431           while (*cp1 != ':') *(cp2++) = *(cp1++);
3432           strcpy(cp2,":[000000]");
3433           cp1 += 2;
3434           strcpy(cp2+9,cp1);
3435         }
3436       }
3437       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3438       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3439       /* We've set up the string up through the filename.  Add the
3440          type and version, and we're done. */
3441       strcat(retspec,".DIR;1");
3442
3443       /* $PARSE may have upcased filespec, so convert output to lower
3444        * case if input contained any lowercase characters. */
3445       if (haslower) __mystrtolower(retspec);
3446       return retspec;
3447     }
3448 }  /* end of do_fileify_dirspec() */
3449 /*}}}*/
3450 /* External entry points */
3451 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3452 { return do_fileify_dirspec(dir,buf,0); }
3453 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3454 { return do_fileify_dirspec(dir,buf,1); }
3455
3456 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3457 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3458 {
3459     static char __pathify_retbuf[NAM$C_MAXRSS+1];
3460     unsigned long int retlen;
3461     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3462     unsigned short int trnlnm_iter_count;
3463     STRLEN trnlen;
3464
3465     if (!dir || !*dir) {
3466       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3467     }
3468
3469     if (*dir) strcpy(trndir,dir);
3470     else getcwd(trndir,sizeof trndir - 1);
3471
3472     trnlnm_iter_count = 0;
3473     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3474            && my_trnlnm(trndir,trndir,0)) {
3475       trnlnm_iter_count++;
3476       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3477       trnlen = strlen(trndir);
3478
3479       /* Trap simple rooted lnms, and return lnm:[000000] */
3480       if (!strcmp(trndir+trnlen-2,".]")) {
3481         if (buf) retpath = buf;
3482         else if (ts) New(1318,retpath,strlen(dir)+10,char);
3483         else retpath = __pathify_retbuf;
3484         strcpy(retpath,dir);
3485         strcat(retpath,":[000000]");
3486         return retpath;
3487       }
3488     }
3489     dir = trndir;
3490
3491     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3492       if (*dir == '.' && (*(dir+1) == '\0' ||
3493                           (*(dir+1) == '.' && *(dir+2) == '\0')))
3494         retlen = 2 + (*(dir+1) != '\0');
3495       else {
3496         if ( !(cp1 = strrchr(dir,'/')) &&
3497              !(cp1 = strrchr(dir,']')) &&
3498              !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3499         if ((cp2 = strchr(cp1,'.')) != NULL &&
3500             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
3501              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
3502               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3503               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3504           int ver; char *cp3;
3505           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3506               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3507               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3508               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3509               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3510                             (ver || *cp3)))))) {
3511             set_errno(ENOTDIR);
3512             set_vaxc_errno(RMS$_DIR);
3513             return NULL;
3514           }
3515           retlen = cp2 - dir + 1;
3516         }
3517         else {  /* No file type present.  Treat the filename as a directory. */
3518           retlen = strlen(dir) + 1;
3519         }
3520       }
3521       if (buf) retpath = buf;
3522       else if (ts) New(1313,retpath,retlen+1,char);
3523       else retpath = __pathify_retbuf;
3524       strncpy(retpath,dir,retlen-1);
3525       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3526         retpath[retlen-1] = '/';      /* with '/', add it. */
3527         retpath[retlen] = '\0';
3528       }
3529       else retpath[retlen-1] = '\0';
3530     }
3531     else {  /* VMS-style directory spec */
3532       char esa[NAM$C_MAXRSS+1], *cp;
3533       unsigned long int sts, cmplen, haslower;
3534       struct FAB dirfab = cc$rms_fab;
3535       struct NAM savnam, dirnam = cc$rms_nam;
3536
3537       /* If we've got an explicit filename, we can just shuffle the string. */
3538       if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3539              (cp1 = strrchr(dir,'>')) != NULL     ) && *(cp1+1)) {
3540         if ((cp2 = strchr(cp1,'.')) != NULL) {
3541           int ver; char *cp3;
3542           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3543               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3544               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3545               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3546               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3547                             (ver || *cp3)))))) {
3548             set_errno(ENOTDIR);
3549             set_vaxc_errno(RMS$_DIR);
3550             return NULL;
3551           }
3552         }
3553         else {  /* No file type, so just draw name into directory part */
3554           for (cp2 = cp1; *cp2; cp2++) ;
3555         }
3556         *cp2 = *cp1;
3557         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
3558         *cp1 = '.';
3559         /* We've now got a VMS 'path'; fall through */
3560       }
3561       dirfab.fab$b_fns = strlen(dir);
3562       dirfab.fab$l_fna = dir;
3563       if (dir[dirfab.fab$b_fns-1] == ']' ||
3564           dir[dirfab.fab$b_fns-1] == '>' ||
3565           dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3566         if (buf) retpath = buf;
3567         else if (ts) New(1314,retpath,strlen(dir)+1,char);
3568         else retpath = __pathify_retbuf;
3569         strcpy(retpath,dir);
3570         return retpath;
3571       }
3572       dirfab.fab$l_dna = ".DIR;1";
3573       dirfab.fab$b_dns = 6;
3574       dirfab.fab$l_nam = &dirnam;
3575       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3576       dirnam.nam$l_esa = esa;
3577
3578       for (cp = dir; *cp; cp++)
3579         if (islower(*cp)) { haslower = 1; break; }
3580
3581       if (!(sts = (sys$parse(&dirfab)&1))) {
3582         if (dirfab.fab$l_sts == RMS$_DIR) {
3583           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3584           sts = sys$parse(&dirfab) & 1;
3585         }
3586         if (!sts) {
3587           set_errno(EVMSERR);
3588           set_vaxc_errno(dirfab.fab$l_sts);
3589           return NULL;
3590         }
3591       }
3592       else {
3593         savnam = dirnam;
3594         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
3595           if (dirfab.fab$l_sts != RMS$_FNF) {
3596             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3597             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3598             set_errno(EVMSERR);
3599             set_vaxc_errno(dirfab.fab$l_sts);
3600             return NULL;
3601           }
3602           dirnam = savnam; /* No; just work with potential name */
3603         }
3604       }
3605       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3606         /* Yep; check version while we're at it, if it's there. */
3607         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3608         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3609           /* Something other than .DIR[;1].  Bzzt. */
3610           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3611           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3612           set_errno(ENOTDIR);
3613           set_vaxc_errno(RMS$_DIR);
3614           return NULL;
3615         }
3616       }
3617       /* OK, the type was fine.  Now pull any file name into the
3618          directory path. */
3619       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3620       else {
3621         cp1 = strrchr(esa,'>');
3622         *dirnam.nam$l_type = '>';
3623       }
3624       *cp1 = '.';
3625       *(dirnam.nam$l_type + 1) = '\0';
3626       retlen = dirnam.nam$l_type - esa + 2;
3627       if (buf) retpath = buf;
3628       else if (ts) New(1314,retpath,retlen,char);
3629       else retpath = __pathify_retbuf;
3630       strcpy(retpath,esa);
3631       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3632       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3633       /* $PARSE may have upcased filespec, so convert output to lower
3634        * case if input contained any lowercase characters. */
3635       if (haslower) __mystrtolower(retpath);
3636     }
3637
3638     return retpath;
3639 }  /* end of do_pathify_dirspec() */
3640 /*}}}*/
3641 /* External entry points */
3642 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3643 { return do_pathify_dirspec(dir,buf,0); }
3644 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3645 { return do_pathify_dirspec(dir,buf,1); }
3646
3647 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3648 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3649 {
3650   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3651   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3652   int devlen, dirlen, retlen = NAM$C_MAXRSS+1;
3653   int expand = 1; /* guarantee room for leading and trailing slashes */
3654   unsigned short int trnlnm_iter_count;
3655
3656   if (spec == NULL) return NULL;
3657   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3658   if (buf) rslt = buf;
3659   else if (ts) {
3660     retlen = strlen(spec);
3661     cp1 = strchr(spec,'[');
3662     if (!cp1) cp1 = strchr(spec,'<');
3663     if (cp1) {
3664       for (cp1++; *cp1; cp1++) {
3665         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
3666         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3667           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3668       }
3669     }
3670     New(1315,rslt,retlen+2+2*expand,char);
3671   }
3672   else rslt = __tounixspec_retbuf;
3673   if (strchr(spec,'/') != NULL) {
3674     strcpy(rslt,spec);
3675     return rslt;
3676   }
3677
3678   cp1 = rslt;
3679   cp2 = spec;
3680   dirend = strrchr(spec,']');
3681   if (dirend == NULL) dirend = strrchr(spec,'>');
3682   if (dirend == NULL) dirend = strchr(spec,':');
3683   if (dirend == NULL) {
3684     strcpy(rslt,spec);
3685     return rslt;
3686   }
3687   if (*cp2 != '[' && *cp2 != '<') {
3688     *(cp1++) = '/';
3689   }
3690   else {  /* the VMS spec begins with directories */
3691     cp2++;
3692     if (*cp2 == ']' || *cp2 == '>') {
3693       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3694       return rslt;
3695     }
3696     else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3697       if (getcwd(tmp,sizeof tmp,1) == NULL) {
3698         if (ts) Safefree(rslt);
3699         return NULL;
3700       }
3701       trnlnm_iter_count = 0;
3702       do {
3703         cp3 = tmp;
3704         while (*cp3 != ':' && *cp3) cp3++;
3705         *(cp3++) = '\0';
3706         if (strchr(cp3,']') != NULL) break;
3707         trnlnm_iter_count++;
3708         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
3709       } while (vmstrnenv(tmp,tmp,0,fildev,0));
3710       if (ts && !buf &&
3711           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3712         retlen = devlen + dirlen;
3713         Renew(rslt,retlen+1+2*expand,char);
3714         cp1 = rslt;
3715       }
3716       cp3 = tmp;
3717       *(cp1++) = '/';
3718       while (*cp3) {
3719         *(cp1++) = *(cp3++);
3720         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3721       }
3722       *(cp1++) = '/';
3723     }
3724     else if ( *cp2 == '.') {
3725       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3726         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3727         cp2 += 3;
3728       }
3729       else cp2++;
3730     }
3731   }
3732   for (; cp2 <= dirend; cp2++) {
3733     if (*cp2 == ':') {
3734       *(cp1++) = '/';
3735       if (*(cp2+1) == '[') cp2++;
3736     }
3737     else if (*cp2 == ']' || *cp2 == '>') {
3738       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3739     }
3740     else if (*cp2 == '.') {
3741       *(cp1++) = '/';
3742       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3743         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3744                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3745         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3746             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3747       }
3748       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3749         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3750         cp2 += 2;
3751       }
3752     }
3753     else if (*cp2 == '-') {
3754       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3755         while (*cp2 == '-') {
3756           cp2++;
3757           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3758         }
3759         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3760           if (ts) Safefree(rslt);                        /* filespecs like */
3761           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
3762           return NULL;
3763         }
3764       }
3765       else *(cp1++) = *cp2;
3766     }
3767     else *(cp1++) = *cp2;
3768   }
3769   while (*cp2) *(cp1++) = *(cp2++);
3770   *cp1 = '\0';
3771
3772   return rslt;
3773
3774 }  /* end of do_tounixspec() */
3775 /*}}}*/
3776 /* External entry points */
3777 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3778 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3779
3780 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3781 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3782   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3783   char *rslt, *dirend;
3784   register char *cp1, *cp2;
3785   unsigned long int infront = 0, hasdir = 1;
3786
3787   if (path == NULL) return NULL;
3788   if (buf) rslt = buf;
3789   else if (ts) New(1316,rslt,strlen(path)+9,char);
3790   else rslt = __tovmsspec_retbuf;
3791   if (strpbrk(path,"]:>") ||
3792       (dirend = strrchr(path,'/')) == NULL) {
3793     if (path[0] == '.') {
3794       if (path[1] == '\0') strcpy(rslt,"[]");
3795       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3796       else strcpy(rslt,path); /* probably garbage */
3797     }
3798     else strcpy(rslt,path);
3799     return rslt;
3800   }
3801   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
3802     if (!*(dirend+2)) dirend +=2;
3803     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3804     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3805   }
3806   cp1 = rslt;
3807   cp2 = path;
3808   if (*cp2 == '/') {
3809     char trndev[NAM$C_MAXRSS+1];
3810     int islnm, rooted;
3811     STRLEN trnend;
3812
3813     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
3814     if (!*(cp2+1)) {
3815       if (!buf & ts) Renew(rslt,18,char);
3816       strcpy(rslt,"sys$disk:[000000]");
3817       return rslt;
3818     }
3819     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3820     *cp1 = '\0';
3821     islnm =  my_trnlnm(rslt,trndev,0);
3822     trnend = islnm ? strlen(trndev) - 1 : 0;
3823     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3824     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3825     /* If the first element of the path is a logical name, determine
3826      * whether it has to be translated so we can add more directories. */
3827     if (!islnm || rooted) {
3828       *(cp1++) = ':';
3829       *(cp1++) = '[';
3830       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3831       else cp2++;
3832     }
3833     else {
3834       if (cp2 != dirend) {
3835         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3836         strcpy(rslt,trndev);
3837         cp1 = rslt + trnend;
3838         *(cp1++) = '.';
3839         cp2++;
3840       }
3841       else {
3842         *(cp1++) = ':';
3843         hasdir = 0;
3844       }
3845     }
3846   }
3847   else {
3848     *(cp1++) = '[';
3849     if (*cp2 == '.') {
3850       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3851         cp2 += 2;         /* skip over "./" - it's redundant */
3852         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
3853       }
3854       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3855         *(cp1++) = '-';                                 /* "../" --> "-" */
3856         cp2 += 3;
3857       }
3858       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3859                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3860         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3861         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3862         cp2 += 4;
3863       }
3864       if (cp2 > dirend) cp2 = dirend;
3865     }
3866     else *(cp1++) = '.';
3867   }
3868   for (; cp2 < dirend; cp2++) {
3869     if (*cp2 == '/') {
3870       if (*(cp2-1) == '/') continue;
3871       if (*(cp1-1) != '.') *(cp1++) = '.';
3872       infront = 0;
3873     }
3874     else if (!infront && *cp2 == '.') {
3875       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3876       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
3877       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3878         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3879         else if (*(cp1-2) == '[') *(cp1-1) = '-';
3880         else {  /* back up over previous directory name */
3881           cp1--;
3882           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3883           if (*(cp1-1) == '[') {
3884             memcpy(cp1,"000000.",7);
3885             cp1 += 7;
3886           }
3887         }
3888         cp2 += 2;
3889         if (cp2 == dirend) break;
3890       }
3891       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3892                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3893         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3894         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3895         if (!*(cp2+3)) {
3896           *(cp1++) = '.';  /* Simulate trailing '/' */
3897           cp2 += 2;  /* for loop will incr this to == dirend */
3898         }
3899         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
3900       }
3901       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
3902     }
3903     else {
3904       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
3905       if (*cp2 == '.')      *(cp1++) = '_';
3906       else                  *(cp1++) =  *cp2;
3907       infront = 1;
3908     }
3909   }
3910   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3911   if (hasdir) *(cp1++) = ']';
3912   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
3913   while (*cp2) *(cp1++) = *(cp2++);
3914   *cp1 = '\0';
3915
3916   return rslt;
3917
3918 }  /* end of do_tovmsspec() */
3919 /*}}}*/
3920 /* External entry points */
3921 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3922 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3923
3924 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3925 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3926   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3927   int vmslen;
3928   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3929
3930   if (path == NULL) return NULL;
3931   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3932   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3933   if (buf) return buf;
3934   else if (ts) {
3935     vmslen = strlen(vmsified);
3936     New(1317,cp,vmslen+1,char);
3937     memcpy(cp,vmsified,vmslen);
3938     cp[vmslen] = '\0';
3939     return cp;
3940   }
3941   else {
3942     strcpy(__tovmspath_retbuf,vmsified);
3943     return __tovmspath_retbuf;
3944   }
3945
3946 }  /* end of do_tovmspath() */
3947 /*}}}*/
3948 /* External entry points */
3949 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3950 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3951
3952
3953 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3954 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3955   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3956   int unixlen;
3957   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3958
3959   if (path == NULL) return NULL;
3960   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3961   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3962   if (buf) return buf;
3963   else if (ts) {
3964     unixlen = strlen(unixified);
3965     New(1317,cp,unixlen+1,char);
3966     memcpy(cp,unixified,unixlen);
3967     cp[unixlen] = '\0';
3968     return cp;
3969   }
3970   else {
3971     strcpy(__tounixpath_retbuf,unixified);
3972     return __tounixpath_retbuf;
3973   }
3974
3975 }  /* end of do_tounixpath() */
3976 /*}}}*/
3977 /* External entry points */
3978 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3979 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3980
3981 /*
3982  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
3983  *
3984  *****************************************************************************
3985  *                                                                           *
3986  *  Copyright (C) 1989-1994 by                                               *
3987  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
3988  *                                                                           *
3989  *  Permission is hereby  granted for the reproduction of this software,     *
3990  *  on condition that this copyright notice is included in the reproduction, *
3991  *  and that such reproduction is not for purposes of profit or material     *
3992  *  gain.                                                                    *
3993  *                                                                           *
3994  *  27-Aug-1994 Modified for inclusion in perl5                              *
3995  *              by Charles Bailey  bailey@newman.upenn.edu                   *
3996  *****************************************************************************
3997  */
3998
3999 /*
4000  * getredirection() is intended to aid in porting C programs
4001  * to VMS (Vax-11 C).  The native VMS environment does not support
4002  * '>' and '<' I/O redirection, or command line wild card expansion,
4003  * or a command line pipe mechanism using the '|' AND background
4004  * command execution '&'.  All of these capabilities are provided to any
4005  * C program which calls this procedure as the first thing in the
4006  * main program.
4007  * The piping mechanism will probably work with almost any 'filter' type
4008  * of program.  With suitable modification, it may useful for other
4009  * portability problems as well.
4010  *
4011  * Author:  Mark Pizzolato      mark@infocomm.com
4012  */
4013 struct list_item
4014     {
4015     struct list_item *next;
4016     char *value;
4017     };
4018
4019 static void add_item(struct list_item **head,
4020                      struct list_item **tail,
4021                      char *value,
4022                      int *count);
4023
4024 static void mp_expand_wild_cards(pTHX_ char *item,
4025                                 struct list_item **head,
4026                                 struct list_item **tail,
4027                                 int *count);
4028
4029 static int background_process(pTHX_ int argc, char **argv);
4030
4031 static void pipe_and_fork(pTHX_ char **cmargv);
4032
4033 /*{{{ void getredirection(int *ac, char ***av)*/
4034 static void
4035 mp_getredirection(pTHX_ int *ac, char ***av)
4036 /*
4037  * Process vms redirection arg's.  Exit if any error is seen.
4038  * If getredirection() processes an argument, it is erased
4039  * from the vector.  getredirection() returns a new argc and argv value.
4040  * In the event that a background command is requested (by a trailing "&"),
4041  * this routine creates a background subprocess, and simply exits the program.
4042  *
4043  * Warning: do not try to simplify the code for vms.  The code
4044  * presupposes that getredirection() is called before any data is
4045  * read from stdin or written to stdout.
4046  *
4047  * Normal usage is as follows:
4048  *
4049  *      main(argc, argv)
4050  *      int             argc;
4051  *      char            *argv[];
4052  *      {
4053  *              getredirection(&argc, &argv);
4054  *      }
4055  */
4056 {
4057     int                 argc = *ac;     /* Argument Count         */
4058     char                **argv = *av;   /* Argument Vector        */
4059     char                *ap;            /* Argument pointer       */
4060     int                 j;              /* argv[] index           */
4061     int                 item_count = 0; /* Count of Items in List */
4062     struct list_item    *list_head = 0; /* First Item in List       */
4063     struct list_item    *list_tail;     /* Last Item in List        */
4064     char                *in = NULL;     /* Input File Name          */
4065     char                *out = NULL;    /* Output File Name         */
4066     char                *outmode = "w"; /* Mode to Open Output File */
4067     char                *err = NULL;    /* Error File Name          */
4068     char                *errmode = "w"; /* Mode to Open Error File  */
4069     int                 cmargc = 0;     /* Piped Command Arg Count  */
4070     char                **cmargv = NULL;/* Piped Command Arg Vector */
4071
4072     /*
4073      * First handle the case where the last thing on the line ends with
4074      * a '&'.  This indicates the desire for the command to be run in a
4075      * subprocess, so we satisfy that desire.
4076      */
4077     ap = argv[argc-1];
4078     if (0 == strcmp("&", ap))
4079        exit(background_process(aTHX_ --argc, argv));
4080     if (*ap && '&' == ap[strlen(ap)-1])
4081         {
4082         ap[strlen(ap)-1] = '\0';
4083        exit(background_process(aTHX_ argc, argv));
4084         }
4085     /*
4086      * Now we handle the general redirection cases that involve '>', '>>',
4087      * '<', and pipes '|'.
4088      */
4089     for (j = 0; j < argc; ++j)
4090         {
4091         if (0 == strcmp("<", argv[j]))
4092             {
4093             if (j+1 >= argc)
4094                 {
4095                 fprintf(stderr,"No input file after < on command line");
4096                 exit(LIB$_WRONUMARG);
4097                 }
4098             in = argv[++j];
4099             continue;
4100             }
4101         if ('<' == *(ap = argv[j]))
4102             {
4103             in = 1 + ap;
4104             continue;
4105             }
4106         if (0 == strcmp(">", ap))
4107             {
4108             if (j+1 >= argc)
4109                 {
4110                 fprintf(stderr,"No output file after > on command line");
4111                 exit(LIB$_WRONUMARG);
4112                 }
4113             out = argv[++j];
4114             continue;
4115             }
4116         if ('>' == *ap)
4117             {
4118             if ('>' == ap[1])
4119                 {
4120                 outmode = "a";
4121                 if ('\0' == ap[2])
4122                     out = argv[++j];
4123                 else
4124                     out = 2 + ap;
4125                 }
4126             else
4127                 out = 1 + ap;
4128             if (j >= argc)
4129                 {
4130                 fprintf(stderr,"No output file after > or >> on command line");
4131                 exit(LIB$_WRONUMARG);
4132                 }
4133             continue;
4134             }
4135         if (('2' == *ap) && ('>' == ap[1]))
4136             {
4137             if ('>' == ap[2])
4138                 {
4139                 errmode = "a";
4140                 if ('\0' == ap[3])
4141                     err = argv[++j];
4142                 else
4143                     err = 3 + ap;
4144                 }
4145             else
4146                 if ('\0' == ap[2])
4147                     err = argv[++j];
4148                 else
4149                     err = 2 + ap;
4150             if (j >= argc)
4151                 {
4152                 fprintf(stderr,"No output file after 2> or 2>> on command line");
4153                 exit(LIB$_WRONUMARG);
4154                 }
4155             continue;
4156             }
4157         if (0 == strcmp("|", argv[j]))
4158             {
4159             if (j+1 >= argc)
4160                 {
4161                 fprintf(stderr,"No command into which to pipe on command line");
4162                 exit(LIB$_WRONUMARG);
4163                 }
4164             cmargc = argc-(j+1);
4165             cmargv = &argv[j+1];
4166             argc = j;
4167             continue;
4168             }
4169         if ('|' == *(ap = argv[j]))
4170             {
4171             ++argv[j];
4172             cmargc = argc-j;
4173             cmargv = &argv[j];
4174             argc = j;
4175             continue;
4176             }
4177         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4178         }
4179     /*
4180      * Allocate and fill in the new argument vector, Some Unix's terminate
4181      * the list with an extra null pointer.
4182      */
4183     New(1302, argv, item_count+1, char *);
4184     *av = argv;
4185     for (j = 0; j < item_count; ++j, list_head = list_head->next)
4186         argv[j] = list_head->value;
4187     *ac = item_count;
4188     if (cmargv != NULL)
4189         {
4190         if (out != NULL)
4191             {
4192             fprintf(stderr,"'|' and '>' may not both be specified on command line");
4193             exit(LIB$_INVARGORD);
4194             }
4195         pipe_and_fork(aTHX_ cmargv);
4196         }
4197
4198     /* Check for input from a pipe (mailbox) */
4199
4200     if (in == NULL && 1 == isapipe(0))
4201         {
4202         char mbxname[L_tmpnam];
4203         long int bufsize;
4204         long int dvi_item = DVI$_DEVBUFSIZ;
4205         $DESCRIPTOR(mbxnam, "");
4206         $DESCRIPTOR(mbxdevnam, "");
4207
4208         /* Input from a pipe, reopen it in binary mode to disable       */
4209         /* carriage control processing.                                 */
4210
4211         fgetname(stdin, mbxname);
4212         mbxnam.dsc$a_pointer = mbxname;
4213         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4214         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4215         mbxdevnam.dsc$a_pointer = mbxname;
4216         mbxdevnam.dsc$w_length = sizeof(mbxname);
4217         dvi_item = DVI$_DEVNAM;
4218         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4219         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4220         set_errno(0);
4221         set_vaxc_errno(1);
4222         freopen(mbxname, "rb", stdin);
4223         if (errno != 0)
4224             {
4225             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4226             exit(vaxc$errno);
4227             }
4228         }
4229     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4230         {
4231         fprintf(stderr,"Can't open input file %s as stdin",in);
4232         exit(vaxc$errno);
4233         }
4234     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4235         {
4236         fprintf(stderr,"Can't open output file %s as stdout",out);
4237         exit(vaxc$errno);
4238         }
4239         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4240
4241     if (err != NULL) {
4242         if (strcmp(err,"&1") == 0) {
4243             dup2(fileno(stdout), fileno(stderr));
4244             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4245         } else {
4246         FILE *tmperr;
4247         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4248             {
4249             fprintf(stderr,"Can't open error file %s as stderr",err);
4250             exit(vaxc$errno);
4251             }
4252             fclose(tmperr);
4253            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4254                 {
4255                 exit(vaxc$errno);
4256                 }
4257             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4258         }
4259         }
4260 #ifdef ARGPROC_DEBUG
4261     PerlIO_printf(Perl_debug_log, "Arglist:\n");
4262     for (j = 0; j < *ac;  ++j)
4263         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4264 #endif
4265    /* Clear errors we may have hit expanding wildcards, so they don't
4266       show up in Perl's $! later */
4267    set_errno(0); set_vaxc_errno(1);
4268 }  /* end of getredirection() */
4269 /*}}}*/
4270
4271 static void add_item(struct list_item **head,
4272                      struct list_item **tail,
4273                      char *value,
4274                      int *count)
4275 {
4276     if (*head == 0)
4277         {
4278         New(1303,*head,1,struct list_item);
4279         *tail = *head;
4280         }
4281     else {
4282         New(1304,(*tail)->next,1,struct list_item);
4283         *tail = (*tail)->next;
4284         }
4285     (*tail)->value = value;
4286     ++(*count);
4287 }
4288
4289 static void mp_expand_wild_cards(pTHX_ char *item,
4290                               struct list_item **head,
4291                               struct list_item **tail,
4292                               int *count)
4293 {
4294 int expcount = 0;
4295 unsigned long int context = 0;
4296 int isunix = 0;
4297 int item_len = 0;
4298 char *had_version;
4299 char *had_device;
4300 int had_directory;
4301 char *devdir,*cp;
4302 char vmsspec[NAM$C_MAXRSS+1];
4303 $DESCRIPTOR(filespec, "");
4304 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4305 $DESCRIPTOR(resultspec, "");
4306 unsigned long int zero = 0, sts;
4307
4308     for (cp = item; *cp; cp++) {
4309         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4310         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4311     }
4312     if (!*cp || isspace(*cp))
4313         {
4314         add_item(head, tail, item, count);
4315         return;
4316         }
4317     else
4318         {
4319      /* "double quoted" wild card expressions pass as is */
4320      /* From DCL that means using e.g.:                  */
4321      /* perl program """perl.*"""                        */
4322      item_len = strlen(item);
4323      if ( '"' == *item && '"' == item[item_len-1] )
4324        {
4325        item++;
4326        item[item_len-2] = '\0';
4327        add_item(head, tail, item, count);
4328        return;
4329        }
4330      }
4331     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4332     resultspec.dsc$b_class = DSC$K_CLASS_D;
4333     resultspec.dsc$a_pointer = NULL;
4334     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4335       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4336     if (!isunix || !filespec.dsc$a_pointer)
4337       filespec.dsc$a_pointer = item;
4338     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4339     /*
4340      * Only return version specs, if the caller specified a version
4341      */
4342     had_version = strchr(item, ';');
4343     /*
4344      * Only return device and directory specs, if the caller specifed either.
4345      */
4346     had_device = strchr(item, ':');
4347     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4348
4349     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4350                                   &defaultspec, 0, 0, &zero))))
4351         {
4352         char *string;
4353         char *c;
4354
4355         New(1305,string,resultspec.dsc$w_length+1,char);
4356         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4357         string[resultspec.dsc$w_length] = '\0';
4358         if (NULL == had_version)
4359             *((char *)strrchr(string, ';')) = '\0';
4360         if ((!had_directory) && (had_device == NULL))
4361             {
4362             if (NULL == (devdir = strrchr(string, ']')))
4363                 devdir = strrchr(string, '>');
4364             strcpy(string, devdir + 1);
4365             }
4366         /*
4367          * Be consistent with what the C RTL has already done to the rest of
4368          * the argv items and lowercase all of these names.
4369          */
4370         for (c = string; *c; ++c)
4371             if (isupper(*c))
4372                 *c = tolower(*c);
4373         if (isunix) trim_unixpath(string,item,1);
4374         add_item(head, tail, string, count);
4375         ++expcount;
4376         }
4377     if (sts != RMS$_NMF)
4378         {
4379         set_vaxc_errno(sts);
4380         switch (sts)
4381             {
4382             case RMS$_FNF: case RMS$_DNF:
4383                 set_errno(ENOENT); break;
4384             case RMS$_DIR:
4385                 set_errno(ENOTDIR); break;
4386             case RMS$_DEV:
4387                 set_errno(ENODEV); break;
4388             case RMS$_FNM: case RMS$_SYN:
4389                 set_errno(EINVAL); break;
4390             case RMS$_PRV:
4391                 set_errno(EACCES); break;
4392             default:
4393                 _ckvmssts_noperl(sts);
4394             }
4395         }
4396     if (expcount == 0)
4397         add_item(head, tail, item, count);
4398     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4399     _ckvmssts_noperl(lib$find_file_end(&context));
4400 }
4401
4402 static int child_st[2];/* Event Flag set when child process completes   */
4403
4404 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
4405
4406 static unsigned long int exit_handler(int *status)
4407 {
4408 short iosb[4];
4409
4410     if (0 == child_st[0])
4411         {
4412 #ifdef ARGPROC_DEBUG
4413         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4414 #endif
4415         fflush(stdout);     /* Have to flush pipe for binary data to    */
4416                             /* terminate properly -- <tp@mccall.com>    */
4417         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4418         sys$dassgn(child_chan);
4419         fclose(stdout);
4420         sys$synch(0, child_st);
4421         }
4422     return(1);
4423 }
4424
4425 static void sig_child(int chan)
4426 {
4427 #ifdef ARGPROC_DEBUG
4428     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4429 #endif
4430     if (child_st[0] == 0)
4431         child_st[0] = 1;
4432 }
4433
4434 static struct exit_control_block exit_block =
4435     {
4436     0,
4437     exit_handler,
4438     1,
4439     &exit_block.exit_status,
4440     0
4441     };
4442
4443 static void
4444 pipe_and_fork(pTHX_ char **cmargv)
4445 {
4446     PerlIO *fp;
4447     struct dsc$descriptor_s *vmscmd;
4448     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4449     int sts, j, l, ismcr, quote, tquote = 0;
4450
4451     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
4452     vms_execfree(vmscmd);
4453
4454     j = l = 0;
4455     p = subcmd;
4456     q = cmargv[0];
4457     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
4458               && toupper(*(q+2)) == 'R' && !*(q+3);
4459
4460     while (q && l < MAX_DCL_LINE_LENGTH) {
4461         if (!*q) {
4462             if (j > 0 && quote) {
4463                 *p++ = '"';
4464                 l++;
4465             }
4466             q = cmargv[++j];
4467             if (q) {
4468                 if (ismcr && j > 1) quote = 1;
4469                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
4470                 *p++ = ' ';
4471                 l++;
4472                 if (quote || tquote) {
4473                     *p++ = '"';
4474                     l++;
4475                 }
4476         }
4477         } else {
4478             if ((quote||tquote) && *q == '"') {
4479                 *p++ = '"';
4480                 l++;
4481         }
4482             *p++ = *q++;
4483             l++;
4484         }
4485     }
4486     *p = '\0';
4487
4488     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4489     if (fp == Nullfp) {
4490         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4491         }
4492 }
4493
4494 static int background_process(pTHX_ int argc, char **argv)
4495 {
4496 char command[2048] = "$";
4497 $DESCRIPTOR(value, "");
4498 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4499 static $DESCRIPTOR(null, "NLA0:");
4500 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4501 char pidstring[80];
4502 $DESCRIPTOR(pidstr, "");
4503 int pid;
4504 unsigned long int flags = 17, one = 1, retsts;
4505
4506     strcat(command, argv[0]);
4507     while (--argc)
4508         {
4509         strcat(command, " \"");
4510         strcat(command, *(++argv));
4511         strcat(command, "\"");
4512         }
4513     value.dsc$a_pointer = command;
4514     value.dsc$w_length = strlen(value.dsc$a_pointer);
4515     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4516     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4517     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4518         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4519     }
4520     else {
4521         _ckvmssts_noperl(retsts);
4522     }
4523 #ifdef ARGPROC_DEBUG
4524     PerlIO_printf(Perl_debug_log, "%s\n", command);
4525 #endif
4526     sprintf(pidstring, "%08X", pid);
4527     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4528     pidstr.dsc$a_pointer = pidstring;
4529     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4530     lib$set_symbol(&pidsymbol, &pidstr);
4531     return(SS$_NORMAL);
4532 }
4533 /*}}}*/
4534 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4535
4536
4537 /* OS-specific initialization at image activation (not thread startup) */
4538 /* Older VAXC header files lack these constants */
4539 #ifndef JPI$_RIGHTS_SIZE
4540 #  define JPI$_RIGHTS_SIZE 817
4541 #endif
4542 #ifndef KGB$M_SUBSYSTEM
4543 #  define KGB$M_SUBSYSTEM 0x8
4544 #endif
4545
4546 /*{{{void vms_image_init(int *, char ***)*/
4547 void
4548 vms_image_init(int *argcp, char ***argvp)
4549 {
4550   char eqv[LNM$C_NAMLENGTH+1] = "";
4551   unsigned int len, tabct = 8, tabidx = 0;
4552   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4553   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4554   unsigned short int dummy, rlen;
4555   struct dsc$descriptor_s **tabvec;
4556 #if defined(PERL_IMPLICIT_CONTEXT)
4557   pTHX = NULL;
4558 #endif
4559   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
4560                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
4561                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4562                                  {          0,                0,    0,      0} };
4563
4564 #ifdef KILL_BY_SIGPRC
4565     (void) Perl_csighandler_init();
4566 #endif
4567
4568   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4569   _ckvmssts_noperl(iosb[0]);
4570   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4571     if (iprv[i]) {           /* Running image installed with privs? */
4572       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
4573       will_taint = TRUE;
4574       break;
4575     }
4576   }
4577   /* Rights identifiers might trigger tainting as well. */
4578   if (!will_taint && (rlen || rsz)) {
4579     while (rlen < rsz) {
4580       /* We didn't get all the identifiers on the first pass.  Allocate a
4581        * buffer much larger than $GETJPI wants (rsz is size in bytes that
4582        * were needed to hold all identifiers at time of last call; we'll
4583        * allocate that many unsigned long ints), and go back and get 'em.
4584        * If it gave us less than it wanted to despite ample buffer space,
4585        * something's broken.  Is your system missing a system identifier?
4586        */
4587       if (rsz <= jpilist[1].buflen) {
4588          /* Perl_croak accvios when used this early in startup. */
4589          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4590                          rsz, (unsigned long) jpilist[1].buflen,
4591                          "Check your rights database for corruption.\n");
4592          exit(SS$_ABORT);
4593       }
4594       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4595       jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4596       jpilist[1].buflen = rsz * sizeof(unsigned long int);
4597       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4598       _ckvmssts_noperl(iosb[0]);
4599     }
4600     mask = jpilist[1].bufadr;
4601     /* Check attribute flags for each identifier (2nd longword); protected
4602      * subsystem identifiers trigger tainting.
4603      */
4604     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4605       if (mask[i] & KGB$M_SUBSYSTEM) {
4606         will_taint = TRUE;
4607         break;
4608       }
4609     }
4610     if (mask != rlst) Safefree(mask);
4611   }
4612   /* We need to use this hack to tell Perl it should run with tainting,
4613    * since its tainting flag may be part of the PL_curinterp struct, which
4614    * hasn't been allocated when vms_image_init() is called.
4615    */
4616   if (will_taint) {
4617     char **newargv, **oldargv;
4618     oldargv = *argvp;
4619     New(1320,newargv,(*argcp)+2,char *);
4620     newargv[0] = oldargv[0];
4621     New(1320,newargv[1],3,char);
4622     strcpy(newargv[1], "-T");
4623     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
4624     (*argcp)++;
4625     newargv[*argcp] = NULL;
4626     /* We orphan the old argv, since we don't know where it's come from,
4627      * so we don't know how to free it.
4628      */
4629     *argvp = newargv;
4630   }
4631   else {  /* Did user explicitly request tainting? */
4632     int i;
4633     char *cp, **av = *argvp;
4634     for (i = 1; i < *argcp; i++) {
4635       if (*av[i] != '-') break;
4636       for (cp = av[i]+1; *cp; cp++) {
4637         if (*cp == 'T') { will_taint = 1; break; }
4638         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4639                   strchr("DFIiMmx",*cp)) break;
4640       }
4641       if (will_taint) break;
4642     }
4643   }
4644
4645   for (tabidx = 0;
4646        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4647        tabidx++) {
4648     if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4649     else if (tabidx >= tabct) {
4650       tabct += 8;
4651       Renew(tabvec,tabct,struct dsc$descriptor_s *);
4652     }
4653     New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4654     tabvec[tabidx]->dsc$w_length  = 0;
4655     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
4656     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
4657     tabvec[tabidx]->dsc$a_pointer = NULL;
4658     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4659   }
4660   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4661
4662   getredirection(argcp,argvp);
4663 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
4664   {
4665 # include <reentrancy.h>
4666   (void) decc$set_reentrancy(C$C_MULTITHREAD);
4667   }
4668 #endif
4669   return;
4670 }
4671 /*}}}*/
4672
4673
4674 /* trim_unixpath()
4675  * Trim Unix-style prefix off filespec, so it looks like what a shell
4676  * glob expansion would return (i.e. from specified prefix on, not
4677  * full path).  Note that returned filespec is Unix-style, regardless
4678  * of whether input filespec was VMS-style or Unix-style.
4679  *
4680  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4681  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
4682  * vector of options; at present, only bit 0 is used, and if set tells
4683  * trim unixpath to try the current default directory as a prefix when
4684  * presented with a possibly ambiguous ... wildcard.
4685  *
4686  * Returns !=0 on success, with trimmed filespec replacing contents of
4687  * fspec, and 0 on failure, with contents of fpsec unchanged.
4688  */
4689 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4690 int
4691 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4692 {
4693   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4694        *template, *base, *end, *cp1, *cp2;
4695   register int tmplen, reslen = 0, dirs = 0;
4696
4697   if (!wildspec || !fspec) return 0;
4698   if (strpbrk(wildspec,"]>:") != NULL) {
4699     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4700     else template = unixwild;
4701   }
4702   else template = wildspec;
4703   if (strpbrk(fspec,"]>:") != NULL) {
4704     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4705     else base = unixified;
4706     /* reslen&nbs