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         Newx(__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         Newx(__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) Newx(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(const char *lnm, const 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_ const char *lnm, const 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 = (char *)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 = (char *)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             Newx(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(const char *lnm, const 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_ const char *lnm, const 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_ const char *, char *, int);
1009 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1010
1011 /*{{{int do_rmdir(char *name)*/
1012 int
1013 Perl_do_rmdir(pTHX_ const 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_ const 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_ const 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_ const 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   Newx(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     Newx(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     Newx(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     Newx(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     Newx(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     Newx(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     Newx(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             Newx(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         Newx(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         Newx(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     Newx(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_ const 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 = Newx(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_ const 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       dir = "/sys$disk";
3144       dirlen = 9;
3145     }
3146     if (dirlen > NAM$C_MAXRSS) {
3147       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3148     }
3149     if (!strpbrk(dir+1,"/]>:")) {
3150       strcpy(trndir,*dir == '/' ? dir + 1: dir);
3151       trnlnm_iter_count = 0;
3152       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
3153         trnlnm_iter_count++;
3154         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3155       }
3156       dirlen = strlen(trndir);
3157     }
3158     else {
3159       strncpy(trndir,dir,dirlen);
3160       trndir[dirlen] = '\0';
3161     }
3162
3163     /* At this point we are done with *dir and use *trndir which is a
3164      * copy that can be modified.  *dir must not be modified.
3165      */
3166
3167     /* If we were handed a rooted logical name or spec, treat it like a
3168      * simple directory, so that
3169      *    $ Define myroot dev:[dir.]
3170      *    ... do_fileify_dirspec("myroot",buf,1) ...
3171      * does something useful.
3172      */
3173     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
3174       trndir[--dirlen] = '\0';
3175       trndir[dirlen-1] = ']';
3176     }
3177     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
3178       trndir[--dirlen] = '\0';
3179       trndir[dirlen-1] = '>';
3180     }
3181
3182     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
3183       /* If we've got an explicit filename, we can just shuffle the string. */
3184       if (*(cp1+1)) hasfilename = 1;
3185       /* Similarly, we can just back up a level if we've got multiple levels
3186          of explicit directories in a VMS spec which ends with directories. */
3187       else {
3188         for (cp2 = cp1; cp2 > trndir; cp2--) {
3189           if (*cp2 == '.') {
3190             *cp2 = *cp1; *cp1 = '\0';
3191             hasfilename = 1;
3192             break;
3193           }
3194           if (*cp2 == '[' || *cp2 == '<') break;
3195         }
3196       }
3197     }
3198
3199     if (hasfilename || !strpbrk(trndir,"]:>")) { /* Unix-style path or filename */
3200       if (trndir[0] == '.') {
3201         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0'))
3202           return do_fileify_dirspec("[]",buf,ts);
3203         else if (trndir[1] == '.' &&
3204                  (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0')))
3205           return do_fileify_dirspec("[-]",buf,ts);
3206       }
3207       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
3208         dirlen -= 1;                 /* to last element */
3209         lastdir = strrchr(trndir,'/');
3210       }
3211       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
3212         /* If we have "/." or "/..", VMSify it and let the VMS code
3213          * below expand it, rather than repeating the code to handle
3214          * relative components of a filespec here */
3215         do {
3216           if (*(cp1+2) == '.') cp1++;
3217           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3218             if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
3219             if (strchr(vmsdir,'/') != NULL) {
3220               /* If do_tovmsspec() returned it, it must have VMS syntax
3221                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
3222                * the time to check this here only so we avoid a recursion
3223                * loop; otherwise, gigo.
3224                */
3225               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
3226             }
3227             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3228             return do_tounixspec(trndir,buf,ts);
3229           }
3230           cp1++;
3231         } while ((cp1 = strstr(cp1,"/.")) != NULL);
3232         lastdir = strrchr(trndir,'/');
3233       }
3234       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
3235         /* Ditto for specs that end in an MFD -- let the VMS code
3236          * figure out whether it's a real device or a rooted logical. */
3237         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
3238         if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
3239         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3240         return do_tounixspec(trndir,buf,ts);
3241       }
3242       else {
3243         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
3244              !(lastdir = cp1 = strrchr(trndir,']')) &&
3245              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
3246         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
3247           int ver; char *cp3;
3248           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3249               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3250               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3251               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3252               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3253                             (ver || *cp3)))))) {
3254             set_errno(ENOTDIR);
3255             set_vaxc_errno(RMS$_DIR);
3256             return NULL;
3257           }
3258           dirlen = cp2 - trndir;
3259         }
3260       }
3261       /* If we lead off with a device or rooted logical, add the MFD
3262          if we're specifying a top-level directory. */
3263       if (lastdir && *trndir == '/') {
3264         addmfd = 1;
3265         for (cp1 = lastdir - 1; cp1 > trndir; cp1--) {
3266           if (*cp1 == '/') {
3267             addmfd = 0;
3268             break;
3269           }
3270         }
3271       }
3272       retlen = dirlen + (addmfd ? 13 : 6);
3273       if (buf) retspec = buf;
3274       else if (ts) Newx(retspec,retlen+1,char);
3275       else retspec = __fileify_retbuf;
3276       if (addmfd) {
3277         dirlen = lastdir - trndir;
3278         memcpy(retspec,trndir,dirlen);
3279         strcpy(&retspec[dirlen],"/000000");
3280         strcpy(&retspec[dirlen+7],lastdir);
3281       }
3282       else {
3283         memcpy(retspec,trndir,dirlen);
3284         retspec[dirlen] = '\0';
3285       }
3286       /* We've picked up everything up to the directory file name.
3287          Now just add the type and version, and we're set. */
3288       strcat(retspec,".dir;1");
3289       return retspec;
3290     }
3291     else {  /* VMS-style directory spec */
3292       char esa[NAM$C_MAXRSS+1], term, *cp;
3293       unsigned long int sts, cmplen, haslower = 0;
3294       struct FAB dirfab = cc$rms_fab;
3295       struct NAM savnam, dirnam = cc$rms_nam;
3296
3297       dirfab.fab$b_fns = strlen(dir);
3298       dirfab.fab$l_fna = trndir;
3299       dirfab.fab$l_nam = &dirnam;
3300       dirfab.fab$l_dna = ".DIR;1";
3301       dirfab.fab$b_dns = 6;
3302       dirnam.nam$b_ess = NAM$C_MAXRSS;
3303       dirnam.nam$l_esa = esa;
3304
3305       for (cp = trndir; *cp; cp++)
3306         if (islower(*cp)) { haslower = 1; break; }
3307       if (!((sts = sys$parse(&dirfab))&1)) {
3308         if (dirfab.fab$l_sts == RMS$_DIR) {
3309           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3310           sts = sys$parse(&dirfab) & 1;
3311         }
3312         if (!sts) {
3313           set_errno(EVMSERR);
3314           set_vaxc_errno(dirfab.fab$l_sts);
3315           return NULL;
3316         }
3317       }
3318       else {
3319         savnam = dirnam;
3320         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
3321           /* Yes; fake the fnb bits so we'll check type below */
3322           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3323         }
3324         else { /* No; just work with potential name */
3325           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3326           else {
3327             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
3328             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3329             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3330             return NULL;
3331           }
3332         }
3333       }
3334       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3335         cp1 = strchr(esa,']');
3336         if (!cp1) cp1 = strchr(esa,'>');
3337         if (cp1) {  /* Should always be true */
3338           dirnam.nam$b_esl -= cp1 - esa - 1;
3339           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3340         }
3341       }
3342       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3343         /* Yep; check version while we're at it, if it's there. */
3344         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3345         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3346           /* Something other than .DIR[;1].  Bzzt. */
3347           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3348           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3349           set_errno(ENOTDIR);
3350           set_vaxc_errno(RMS$_DIR);
3351           return NULL;
3352         }
3353       }
3354       esa[dirnam.nam$b_esl] = '\0';
3355       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3356         /* They provided at least the name; we added the type, if necessary, */
3357         if (buf) retspec = buf;                            /* in sys$parse() */
3358         else if (ts) Newx(retspec,dirnam.nam$b_esl+1,char);
3359         else retspec = __fileify_retbuf;
3360         strcpy(retspec,esa);
3361         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3362         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3363         return retspec;
3364       }
3365       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3366         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3367         *cp1 = '\0';
3368         dirnam.nam$b_esl -= 9;
3369       }
3370       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3371       if (cp1 == NULL) { /* should never happen */
3372         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3373         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3374         return NULL;
3375       }
3376       term = *cp1;
3377       *cp1 = '\0';
3378       retlen = strlen(esa);
3379       if ((cp1 = strrchr(esa,'.')) != NULL) {
3380         /* There's more than one directory in the path.  Just roll back. */
3381         *cp1 = term;
3382         if (buf) retspec = buf;
3383         else if (ts) Newx(retspec,retlen+7,char);
3384         else retspec = __fileify_retbuf;
3385         strcpy(retspec,esa);
3386       }
3387       else {
3388         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3389           /* Go back and expand rooted logical name */
3390           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3391           if (!(sys$parse(&dirfab) & 1)) {
3392             dirnam.nam$l_rlf = NULL;
3393             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3394             set_errno(EVMSERR);
3395             set_vaxc_errno(dirfab.fab$l_sts);
3396             return NULL;
3397           }
3398           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3399           if (buf) retspec = buf;
3400           else if (ts) Newx(retspec,retlen+16,char);
3401           else retspec = __fileify_retbuf;
3402           cp1 = strstr(esa,"][");
3403           if (!cp1) cp1 = strstr(esa,"]<");
3404           dirlen = cp1 - esa;
3405           memcpy(retspec,esa,dirlen);
3406           if (!strncmp(cp1+2,"000000]",7)) {
3407             retspec[dirlen-1] = '\0';
3408             for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3409             if (*cp1 == '.') *cp1 = ']';
3410             else {
3411               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3412               memcpy(cp1+1,"000000]",7);
3413             }
3414           }
3415           else {
3416             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3417             retspec[retlen] = '\0';
3418             /* Convert last '.' to ']' */
3419             for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3420             if (*cp1 == '.') *cp1 = ']';
3421             else {
3422               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3423               memcpy(cp1+1,"000000]",7);
3424             }
3425           }
3426         }
3427         else {  /* This is a top-level dir.  Add the MFD to the path. */
3428           if (buf) retspec = buf;
3429           else if (ts) Newx(retspec,retlen+16,char);
3430           else retspec = __fileify_retbuf;
3431           cp1 = esa;
3432           cp2 = retspec;
3433           while (*cp1 != ':') *(cp2++) = *(cp1++);
3434           strcpy(cp2,":[000000]");
3435           cp1 += 2;
3436           strcpy(cp2+9,cp1);
3437         }
3438       }
3439       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3440       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3441       /* We've set up the string up through the filename.  Add the
3442          type and version, and we're done. */
3443       strcat(retspec,".DIR;1");
3444
3445       /* $PARSE may have upcased filespec, so convert output to lower
3446        * case if input contained any lowercase characters. */
3447       if (haslower) __mystrtolower(retspec);
3448       return retspec;
3449     }
3450 }  /* end of do_fileify_dirspec() */
3451 /*}}}*/
3452 /* External entry points */
3453 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
3454 { return do_fileify_dirspec(dir,buf,0); }
3455 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
3456 { return do_fileify_dirspec(dir,buf,1); }
3457
3458 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3459 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
3460 {
3461     static char __pathify_retbuf[NAM$C_MAXRSS+1];
3462     unsigned long int retlen;
3463     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3464     unsigned short int trnlnm_iter_count;
3465     STRLEN trnlen;
3466
3467     if (!dir || !*dir) {
3468       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3469     }
3470
3471     if (*dir) strcpy(trndir,dir);
3472     else getcwd(trndir,sizeof trndir - 1);
3473
3474     trnlnm_iter_count = 0;
3475     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3476            && my_trnlnm(trndir,trndir,0)) {
3477       trnlnm_iter_count++;
3478       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3479       trnlen = strlen(trndir);
3480
3481       /* Trap simple rooted lnms, and return lnm:[000000] */
3482       if (!strcmp(trndir+trnlen-2,".]")) {
3483         if (buf) retpath = buf;
3484         else if (ts) Newx(retpath,strlen(dir)+10,char);
3485         else retpath = __pathify_retbuf;
3486         strcpy(retpath,dir);
3487         strcat(retpath,":[000000]");
3488         return retpath;
3489       }
3490     }
3491
3492     /* At this point we do not work with *dir, but the copy in
3493      * *trndir that is modifiable.
3494      */
3495
3496     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
3497       if (*trndir == '.' && (*(trndir+1) == '\0' ||
3498                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
3499         retlen = 2 + (*(trndir+1) != '\0');
3500       else {
3501         if ( !(cp1 = strrchr(trndir,'/')) &&
3502              !(cp1 = strrchr(trndir,']')) &&
3503              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
3504         if ((cp2 = strchr(cp1,'.')) != NULL &&
3505             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
3506              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
3507               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3508               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3509           int ver; char *cp3;
3510           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3511               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3512               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3513               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3514               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3515                             (ver || *cp3)))))) {
3516             set_errno(ENOTDIR);
3517             set_vaxc_errno(RMS$_DIR);
3518             return NULL;
3519           }
3520           retlen = cp2 - trndir + 1;
3521         }
3522         else {  /* No file type present.  Treat the filename as a directory. */
3523           retlen = strlen(trndir) + 1;
3524         }
3525       }
3526       if (buf) retpath = buf;
3527       else if (ts) Newx(retpath,retlen+1,char);
3528       else retpath = __pathify_retbuf;
3529       strncpy(retpath, trndir, retlen-1);
3530       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3531         retpath[retlen-1] = '/';      /* with '/', add it. */
3532         retpath[retlen] = '\0';
3533       }
3534       else retpath[retlen-1] = '\0';
3535     }
3536     else {  /* VMS-style directory spec */
3537       char esa[NAM$C_MAXRSS+1], *cp;
3538       unsigned long int sts, cmplen, haslower;
3539       struct FAB dirfab = cc$rms_fab;
3540       struct NAM savnam, dirnam = cc$rms_nam;
3541
3542       /* If we've got an explicit filename, we can just shuffle the string. */
3543       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
3544              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
3545         if ((cp2 = strchr(cp1,'.')) != NULL) {
3546           int ver; char *cp3;
3547           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3548               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3549               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3550               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3551               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3552                             (ver || *cp3)))))) {
3553             set_errno(ENOTDIR);
3554             set_vaxc_errno(RMS$_DIR);
3555             return NULL;
3556           }
3557         }
3558         else {  /* No file type, so just draw name into directory part */
3559           for (cp2 = cp1; *cp2; cp2++) ;
3560         }
3561         *cp2 = *cp1;
3562         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
3563         *cp1 = '.';
3564         /* We've now got a VMS 'path'; fall through */
3565       }
3566       dirfab.fab$b_fns = strlen(trndir);
3567       dirfab.fab$l_fna = trndir;
3568       if (dir[dirfab.fab$b_fns-1] == ']' ||
3569           dir[dirfab.fab$b_fns-1] == '>' ||
3570           dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3571         if (buf) retpath = buf;
3572         else if (ts) Newx(retpath,strlen(dir)+1,char);
3573         else retpath = __pathify_retbuf;
3574         strcpy(retpath,trndir);
3575         return retpath;
3576       }
3577       dirfab.fab$l_dna = ".DIR;1";
3578       dirfab.fab$b_dns = 6;
3579       dirfab.fab$l_nam = &dirnam;
3580       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3581       dirnam.nam$l_esa = esa;
3582
3583       for (cp = trndir; *cp; cp++)
3584         if (islower(*cp)) { haslower = 1; break; }
3585
3586       if (!(sts = (sys$parse(&dirfab)&1))) {
3587         if (dirfab.fab$l_sts == RMS$_DIR) {
3588           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3589           sts = sys$parse(&dirfab) & 1;
3590         }
3591         if (!sts) {
3592           set_errno(EVMSERR);
3593           set_vaxc_errno(dirfab.fab$l_sts);
3594           return NULL;
3595         }
3596       }
3597       else {
3598         savnam = dirnam;
3599         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
3600           if (dirfab.fab$l_sts != RMS$_FNF) {
3601             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3602             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3603             set_errno(EVMSERR);
3604             set_vaxc_errno(dirfab.fab$l_sts);
3605             return NULL;
3606           }
3607           dirnam = savnam; /* No; just work with potential name */
3608         }
3609       }
3610       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3611         /* Yep; check version while we're at it, if it's there. */
3612         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3613         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3614           /* Something other than .DIR[;1].  Bzzt. */
3615           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3616           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3617           set_errno(ENOTDIR);
3618           set_vaxc_errno(RMS$_DIR);
3619           return NULL;
3620         }
3621       }
3622       /* OK, the type was fine.  Now pull any file name into the
3623          directory path. */
3624       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3625       else {
3626         cp1 = strrchr(esa,'>');
3627         *dirnam.nam$l_type = '>';
3628       }
3629       *cp1 = '.';
3630       *(dirnam.nam$l_type + 1) = '\0';
3631       retlen = dirnam.nam$l_type - esa + 2;
3632       if (buf) retpath = buf;
3633       else if (ts) Newx(retpath,retlen,char);
3634       else retpath = __pathify_retbuf;
3635       strcpy(retpath,esa);
3636       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3637       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3638       /* $PARSE may have upcased filespec, so convert output to lower
3639        * case if input contained any lowercase characters. */
3640       if (haslower) __mystrtolower(retpath);
3641     }
3642
3643     return retpath;
3644 }  /* end of do_pathify_dirspec() */
3645 /*}}}*/
3646 /* External entry points */
3647 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
3648 { return do_pathify_dirspec(dir,buf,0); }
3649 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
3650 { return do_pathify_dirspec(dir,buf,1); }
3651
3652 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3653 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
3654 {
3655   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3656   char *dirend, *rslt, *cp1, *cp3, tmp[NAM$C_MAXRSS+1];
3657   const char *cp2;
3658   int devlen, dirlen, retlen = NAM$C_MAXRSS+1;
3659   int expand = 1; /* guarantee room for leading and trailing slashes */
3660   unsigned short int trnlnm_iter_count;
3661
3662   if (spec == NULL) return NULL;
3663   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3664   if (buf) rslt = buf;
3665   else if (ts) {
3666     retlen = strlen(spec);
3667     cp1 = strchr(spec,'[');
3668     if (!cp1) cp1 = strchr(spec,'<');
3669     if (cp1) {
3670       for (cp1++; *cp1; cp1++) {
3671         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
3672         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3673           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3674       }
3675     }
3676     Newx(rslt,retlen+2+2*expand,char);
3677   }
3678   else rslt = __tounixspec_retbuf;
3679   if (strchr(spec,'/') != NULL) {
3680     strcpy(rslt,spec);
3681     return rslt;
3682   }
3683
3684   cp1 = rslt;
3685   cp2 = spec;
3686   dirend = strrchr(spec,']');
3687   if (dirend == NULL) dirend = strrchr(spec,'>');
3688   if (dirend == NULL) dirend = strchr(spec,':');
3689   if (dirend == NULL) {
3690     strcpy(rslt,spec);
3691     return rslt;
3692   }
3693   if (*cp2 != '[' && *cp2 != '<') {
3694     *(cp1++) = '/';
3695   }
3696   else {  /* the VMS spec begins with directories */
3697     cp2++;
3698     if (*cp2 == ']' || *cp2 == '>') {
3699       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3700       return rslt;
3701     }
3702     else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3703       if (getcwd(tmp,sizeof tmp,1) == NULL) {
3704         if (ts) Safefree(rslt);
3705         return NULL;
3706       }
3707       trnlnm_iter_count = 0;
3708       do {
3709         cp3 = tmp;
3710         while (*cp3 != ':' && *cp3) cp3++;
3711         *(cp3++) = '\0';
3712         if (strchr(cp3,']') != NULL) break;
3713         trnlnm_iter_count++;
3714         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
3715       } while (vmstrnenv(tmp,tmp,0,fildev,0));
3716       if (ts && !buf &&
3717           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3718         retlen = devlen + dirlen;
3719         Renew(rslt,retlen+1+2*expand,char);
3720         cp1 = rslt;
3721       }
3722       cp3 = tmp;
3723       *(cp1++) = '/';
3724       while (*cp3) {
3725         *(cp1++) = *(cp3++);
3726         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3727       }
3728       *(cp1++) = '/';
3729     }
3730     else if ( *cp2 == '.') {
3731       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3732         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3733         cp2 += 3;
3734       }
3735       else cp2++;
3736     }
3737   }
3738   for (; cp2 <= dirend; cp2++) {
3739     if (*cp2 == ':') {
3740       *(cp1++) = '/';
3741       if (*(cp2+1) == '[') cp2++;
3742     }
3743     else if (*cp2 == ']' || *cp2 == '>') {
3744       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3745     }
3746     else if (*cp2 == '.') {
3747       *(cp1++) = '/';
3748       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3749         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3750                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3751         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3752             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3753       }
3754       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3755         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3756         cp2 += 2;
3757       }
3758     }
3759     else if (*cp2 == '-') {
3760       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3761         while (*cp2 == '-') {
3762           cp2++;
3763           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3764         }
3765         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3766           if (ts) Safefree(rslt);                        /* filespecs like */
3767           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
3768           return NULL;
3769         }
3770       }
3771       else *(cp1++) = *cp2;
3772     }
3773     else *(cp1++) = *cp2;
3774   }
3775   while (*cp2) *(cp1++) = *(cp2++);
3776   *cp1 = '\0';
3777
3778   return rslt;
3779
3780 }  /* end of do_tounixspec() */
3781 /*}}}*/
3782 /* External entry points */
3783 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3784 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3785
3786 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3787 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
3788   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3789   char *rslt, *dirend;
3790   register char *cp1;
3791   const char *cp2;
3792   unsigned long int infront = 0, hasdir = 1;
3793
3794   if (path == NULL) return NULL;
3795   if (buf) rslt = buf;
3796   else if (ts) Newx(rslt,strlen(path)+9,char);
3797   else rslt = __tovmsspec_retbuf;
3798   if (strpbrk(path,"]:>") ||
3799       (dirend = strrchr(path,'/')) == NULL) {
3800     if (path[0] == '.') {
3801       if (path[1] == '\0') strcpy(rslt,"[]");
3802       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3803       else strcpy(rslt,path); /* probably garbage */
3804     }
3805     else strcpy(rslt,path);
3806     return rslt;
3807   }
3808   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
3809     if (!*(dirend+2)) dirend +=2;
3810     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3811     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3812   }
3813   cp1 = rslt;
3814   cp2 = path;
3815   if (*cp2 == '/') {
3816     char trndev[NAM$C_MAXRSS+1];
3817     int islnm, rooted;
3818     STRLEN trnend;
3819
3820     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
3821     if (!*(cp2+1)) {
3822       if (!buf & ts) Renew(rslt,18,char);
3823       strcpy(rslt,"sys$disk:[000000]");
3824       return rslt;
3825     }
3826     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3827     *cp1 = '\0';
3828     islnm =  my_trnlnm(rslt,trndev,0);
3829     trnend = islnm ? strlen(trndev) - 1 : 0;
3830     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3831     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3832     /* If the first element of the path is a logical name, determine
3833      * whether it has to be translated so we can add more directories. */
3834     if (!islnm || rooted) {
3835       *(cp1++) = ':';
3836       *(cp1++) = '[';
3837       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3838       else cp2++;
3839     }
3840     else {
3841       if (cp2 != dirend) {
3842         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3843         strcpy(rslt,trndev);
3844         cp1 = rslt + trnend;
3845         if (*cp2 != 0) {
3846           *(cp1++) = '.';
3847           cp2++;
3848         }
3849       }
3850       else {
3851         *(cp1++) = ':';
3852         hasdir = 0;
3853       }
3854     }
3855   }
3856   else {
3857     *(cp1++) = '[';
3858     if (*cp2 == '.') {
3859       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3860         cp2 += 2;         /* skip over "./" - it's redundant */
3861         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
3862       }
3863       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3864         *(cp1++) = '-';                                 /* "../" --> "-" */
3865         cp2 += 3;
3866       }
3867       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3868                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3869         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3870         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3871         cp2 += 4;
3872       }
3873       if (cp2 > dirend) cp2 = dirend;
3874     }
3875     else *(cp1++) = '.';
3876   }
3877   for (; cp2 < dirend; cp2++) {
3878     if (*cp2 == '/') {
3879       if (*(cp2-1) == '/') continue;
3880       if (*(cp1-1) != '.') *(cp1++) = '.';
3881       infront = 0;
3882     }
3883     else if (!infront && *cp2 == '.') {
3884       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3885       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
3886       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3887         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3888         else if (*(cp1-2) == '[') *(cp1-1) = '-';
3889         else {  /* back up over previous directory name */
3890           cp1--;
3891           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3892           if (*(cp1-1) == '[') {
3893             memcpy(cp1,"000000.",7);
3894             cp1 += 7;
3895           }
3896         }
3897         cp2 += 2;
3898         if (cp2 == dirend) break;
3899       }
3900       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3901                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3902         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3903         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3904         if (!*(cp2+3)) {
3905           *(cp1++) = '.';  /* Simulate trailing '/' */
3906           cp2 += 2;  /* for loop will incr this to == dirend */
3907         }
3908         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
3909       }
3910       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
3911     }
3912     else {
3913       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
3914       if (*cp2 == '.')      *(cp1++) = '_';
3915       else                  *(cp1++) =  *cp2;
3916       infront = 1;
3917     }
3918   }
3919   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3920   if (hasdir) *(cp1++) = ']';
3921   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
3922   while (*cp2) *(cp1++) = *(cp2++);
3923   *cp1 = '\0';
3924
3925   return rslt;
3926
3927 }  /* end of do_tovmsspec() */
3928 /*}}}*/
3929 /* External entry points */
3930 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3931 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3932
3933 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3934 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
3935   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3936   int vmslen;
3937   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3938
3939   if (path == NULL) return NULL;
3940   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3941   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3942   if (buf) return buf;
3943   else if (ts) {
3944     vmslen = strlen(vmsified);
3945     Newx(cp,vmslen+1,char);
3946     memcpy(cp,vmsified,vmslen);
3947     cp[vmslen] = '\0';
3948     return cp;
3949   }
3950   else {
3951     strcpy(__tovmspath_retbuf,vmsified);
3952     return __tovmspath_retbuf;
3953   }
3954
3955 }  /* end of do_tovmspath() */
3956 /*}}}*/
3957 /* External entry points */
3958 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
3959 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
3960
3961
3962 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3963 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
3964   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3965   int unixlen;
3966   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3967
3968   if (path == NULL) return NULL;
3969   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3970   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3971   if (buf) return buf;
3972   else if (ts) {
3973     unixlen = strlen(unixified);
3974     Newx(cp,unixlen+1,char);
3975     memcpy(cp,unixified,unixlen);
3976     cp[unixlen] = '\0';
3977     return cp;
3978   }
3979   else {
3980     strcpy(__tounixpath_retbuf,unixified);
3981     return __tounixpath_retbuf;
3982   }
3983
3984 }  /* end of do_tounixpath() */
3985 /*}}}*/
3986 /* External entry points */
3987 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
3988 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
3989
3990 /*
3991  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
3992  *
3993  *****************************************************************************
3994  *                                                                           *
3995  *  Copyright (C) 1989-1994 by                                               *
3996  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
3997  *                                                                           *
3998  *  Permission is hereby  granted for the reproduction of this software,     *
3999  *  on condition that this copyright notice is included in the reproduction, *
4000  *  and that such reproduction is not for purposes of profit or material     *
4001  *  gain.                                                                    *
4002  *                                                                           *
4003  *  27-Aug-1994 Modified for inclusion in perl5                              *
4004  *              by Charles Bailey  bailey@newman.upenn.edu                   *
4005  *****************************************************************************
4006  */
4007
4008 /*
4009  * getredirection() is intended to aid in porting C programs
4010  * to VMS (Vax-11 C).  The native VMS environment does not support
4011  * '>' and '<' I/O redirection, or command line wild card expansion,
4012  * or a command line pipe mechanism using the '|' AND background
4013  * command execution '&'.  All of these capabilities are provided to any
4014  * C program which calls this procedure as the first thing in the
4015  * main program.
4016  * The piping mechanism will probably work with almost any 'filter' type
4017  * of program.  With suitable modification, it may useful for other
4018  * portability problems as well.
4019  *
4020  * Author:  Mark Pizzolato      mark@infocomm.com
4021  */
4022 struct list_item
4023     {
4024     struct list_item *next;
4025     char *value;
4026     };
4027
4028 static void add_item(struct list_item **head,
4029                      struct list_item **tail,
4030                      char *value,
4031                      int *count);
4032
4033 static void mp_expand_wild_cards(pTHX_ char *item,
4034                                 struct list_item **head,
4035                                 struct list_item **tail,
4036                                 int *count);
4037
4038 static int background_process(pTHX_ int argc, char **argv);
4039
4040 static void pipe_and_fork(pTHX_ char **cmargv);
4041
4042 /*{{{ void getredirection(int *ac, char ***av)*/
4043 static void
4044 mp_getredirection(pTHX_ int *ac, char ***av)
4045 /*
4046  * Process vms redirection arg's.  Exit if any error is seen.
4047  * If getredirection() processes an argument, it is erased
4048  * from the vector.  getredirection() returns a new argc and argv value.
4049  * In the event that a background command is requested (by a trailing "&"),
4050  * this routine creates a background subprocess, and simply exits the program.
4051  *
4052  * Warning: do not try to simplify the code for vms.  The code
4053  * presupposes that getredirection() is called before any data is
4054  * read from stdin or written to stdout.
4055  *
4056  * Normal usage is as follows:
4057  *
4058  *      main(argc, argv)
4059  *      int             argc;
4060  *      char            *argv[];
4061  *      {
4062  *              getredirection(&argc, &argv);
4063  *      }
4064  */
4065 {
4066     int                 argc = *ac;     /* Argument Count         */
4067     char                **argv = *av;   /* Argument Vector        */
4068     char                *ap;            /* Argument pointer       */
4069     int                 j;              /* argv[] index           */
4070     int                 item_count = 0; /* Count of Items in List */
4071     struct list_item    *list_head = 0; /* First Item in List       */
4072     struct list_item    *list_tail;     /* Last Item in List        */
4073     char                *in = NULL;     /* Input File Name          */
4074     char                *out = NULL;    /* Output File Name         */
4075     char                *outmode = "w"; /* Mode to Open Output File */
4076     char                *err = NULL;    /* Error File Name          */
4077     char                *errmode = "w"; /* Mode to Open Error File  */
4078     int                 cmargc = 0;     /* Piped Command Arg Count  */
4079     char                **cmargv = NULL;/* Piped Command Arg Vector */
4080
4081     /*
4082      * First handle the case where the last thing on the line ends with
4083      * a '&'.  This indicates the desire for the command to be run in a
4084      * subprocess, so we satisfy that desire.
4085      */
4086     ap = argv[argc-1];
4087     if (0 == strcmp("&", ap))
4088        exit(background_process(aTHX_ --argc, argv));
4089     if (*ap && '&' == ap[strlen(ap)-1])
4090         {
4091         ap[strlen(ap)-1] = '\0';
4092        exit(background_process(aTHX_ argc, argv));
4093         }
4094     /*
4095      * Now we handle the general redirection cases that involve '>', '>>',
4096      * '<', and pipes '|'.
4097      */
4098     for (j = 0; j < argc; ++j)
4099         {
4100         if (0 == strcmp("<", argv[j]))
4101             {
4102             if (j+1 >= argc)
4103                 {
4104                 fprintf(stderr,"No input file after < on command line");
4105                 exit(LIB$_WRONUMARG);
4106                 }
4107             in = argv[++j];
4108             continue;
4109             }
4110         if ('<' == *(ap = argv[j]))
4111             {
4112             in = 1 + ap;
4113             continue;
4114             }
4115         if (0 == strcmp(">", ap))
4116             {
4117             if (j+1 >= argc)
4118                 {
4119                 fprintf(stderr,"No output file after > on command line");
4120                 exit(LIB$_WRONUMARG);
4121                 }
4122             out = argv[++j];
4123             continue;
4124             }
4125         if ('>' == *ap)
4126             {
4127             if ('>' == ap[1])
4128                 {
4129                 outmode = "a";
4130                 if ('\0' == ap[2])
4131                     out = argv[++j];
4132                 else
4133                     out = 2 + ap;
4134                 }
4135             else
4136                 out = 1 + ap;
4137             if (j >= argc)
4138                 {
4139                 fprintf(stderr,"No output file after > or >> on command line");
4140                 exit(LIB$_WRONUMARG);
4141                 }
4142             continue;
4143             }
4144         if (('2' == *ap) && ('>' == ap[1]))
4145             {
4146             if ('>' == ap[2])
4147                 {
4148                 errmode = "a";
4149                 if ('\0' == ap[3])
4150                     err = argv[++j];
4151                 else
4152                     err = 3 + ap;
4153                 }
4154             else
4155                 if ('\0' == ap[2])
4156                     err = argv[++j];
4157                 else
4158                     err = 2 + ap;
4159             if (j >= argc)
4160                 {
4161                 fprintf(stderr,"No output file after 2> or 2>> on command line");
4162                 exit(LIB$_WRONUMARG);
4163                 }
4164             continue;
4165             }
4166         if (0 == strcmp("|", argv[j]))
4167             {
4168             if (j+1 >= argc)
4169                 {
4170                 fprintf(stderr,"No command into which to pipe on command line");
4171                 exit(LIB$_WRONUMARG);
4172                 }
4173             cmargc = argc-(j+1);
4174             cmargv = &argv[j+1];
4175             argc = j;
4176             continue;
4177             }
4178         if ('|' == *(ap = argv[j]))
4179             {
4180             ++argv[j];
4181             cmargc = argc-j;
4182             cmargv = &argv[j];
4183             argc = j;
4184             continue;
4185             }
4186         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4187         }
4188     /*
4189      * Allocate and fill in the new argument vector, Some Unix's terminate
4190      * the list with an extra null pointer.
4191      */
4192     Newx(argv, item_count+1, char *);
4193     *av = argv;
4194     for (j = 0; j < item_count; ++j, list_head = list_head->next)
4195         argv[j] = list_head->value;
4196     *ac = item_count;
4197     if (cmargv != NULL)
4198         {
4199         if (out != NULL)
4200             {
4201             fprintf(stderr,"'|' and '>' may not both be specified on command line");
4202             exit(LIB$_INVARGORD);
4203             }
4204         pipe_and_fork(aTHX_ cmargv);
4205         }
4206
4207     /* Check for input from a pipe (mailbox) */
4208
4209     if (in == NULL && 1 == isapipe(0))
4210         {
4211         char mbxname[L_tmpnam];
4212         long int bufsize;
4213         long int dvi_item = DVI$_DEVBUFSIZ;
4214         $DESCRIPTOR(mbxnam, "");
4215         $DESCRIPTOR(mbxdevnam, "");
4216
4217         /* Input from a pipe, reopen it in binary mode to disable       */
4218         /* carriage control processing.                                 */
4219
4220         fgetname(stdin, mbxname);
4221         mbxnam.dsc$a_pointer = mbxname;
4222         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4223         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4224         mbxdevnam.dsc$a_pointer = mbxname;
4225         mbxdevnam.dsc$w_length = sizeof(mbxname);
4226         dvi_item = DVI$_DEVNAM;
4227         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4228         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4229         set_errno(0);
4230         set_vaxc_errno(1);
4231         freopen(mbxname, "rb", stdin);
4232         if (errno != 0)
4233             {
4234             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4235             exit(vaxc$errno);
4236             }
4237         }
4238     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4239         {
4240         fprintf(stderr,"Can't open input file %s as stdin",in);
4241         exit(vaxc$errno);
4242         }
4243     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4244         {
4245         fprintf(stderr,"Can't open output file %s as stdout",out);
4246         exit(vaxc$errno);
4247         }
4248         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4249
4250     if (err != NULL) {
4251         if (strcmp(err,"&1") == 0) {
4252             dup2(fileno(stdout), fileno(stderr));
4253             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4254         } else {
4255         FILE *tmperr;
4256         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4257             {
4258             fprintf(stderr,"Can't open error file %s as stderr",err);
4259             exit(vaxc$errno);
4260             }
4261             fclose(tmperr);
4262            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4263                 {
4264                 exit(vaxc$errno);
4265                 }
4266             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4267         }
4268         }
4269 #ifdef ARGPROC_DEBUG
4270     PerlIO_printf(Perl_debug_log, "Arglist:\n");
4271     for (j = 0; j < *ac;  ++j)
4272         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4273 #endif
4274    /* Clear errors we may have hit expanding wildcards, so they don't
4275       show up in Perl's $! later */
4276    set_errno(0); set_vaxc_errno(1);
4277 }  /* end of getredirection() */
4278 /*}}}*/
4279
4280 static void add_item(struct list_item **head,
4281                      struct list_item **tail,
4282                      char *value,
4283                      int *count)
4284 {
4285     if (*head == 0)
4286         {
4287         Newx(*head,1,struct list_item);
4288         *tail = *head;
4289         }
4290     else {
4291         Newx((*tail)->next,1,struct list_item);
4292         *tail = (*tail)->next;
4293         }
4294     (*tail)->value = value;
4295     ++(*count);
4296 }
4297
4298 static void mp_expand_wild_cards(pTHX_ char *item,
4299                               struct list_item **head,
4300                               struct list_item **tail,
4301                               int *count)
4302 {
4303 int expcount = 0;
4304 unsigned long int context = 0;
4305 int isunix = 0;
4306 int item_len = 0;
4307 char *had_version;
4308 char *had_device;
4309 int had_directory;
4310 char *devdir,*cp;
4311 char vmsspec[NAM$C_MAXRSS+1];
4312 $DESCRIPTOR(filespec, "");
4313 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4314 $DESCRIPTOR(resultspec, "");
4315 unsigned long int zero = 0, sts;
4316
4317     for (cp = item; *cp; cp++) {
4318         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4319         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4320     }
4321     if (!*cp || isspace(*cp))
4322         {
4323         add_item(head, tail, item, count);
4324         return;
4325         }
4326     else
4327         {
4328      /* "double quoted" wild card expressions pass as is */
4329      /* From DCL that means using e.g.:                  */
4330      /* perl program """perl.*"""                        */
4331      item_len = strlen(item);
4332      if ( '"' == *item && '"' == item[item_len-1] )
4333        {
4334        item++;
4335        item[item_len-2] = '\0';
4336        add_item(head, tail, item, count);
4337        return;
4338        }
4339      }
4340     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4341     resultspec.dsc$b_class = DSC$K_CLASS_D;
4342     resultspec.dsc$a_pointer = NULL;
4343     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4344       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4345     if (!isunix || !filespec.dsc$a_pointer)
4346       filespec.dsc$a_pointer = item;
4347     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4348     /*
4349      * Only return version specs, if the caller specified a version
4350      */
4351     had_version = strchr(item, ';');
4352     /*
4353      * Only return device and directory specs, if the caller specifed either.
4354      */
4355     had_device = strchr(item, ':');
4356     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4357
4358     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4359                                   &defaultspec, 0, 0, &zero))))
4360         {
4361         char *string;
4362         char *c;
4363
4364         Newx(string,resultspec.dsc$w_length+1,char);
4365         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4366         string[resultspec.dsc$w_length] = '\0';
4367         if (NULL == had_version)
4368             *((char *)strrchr(string, ';')) = '\0';
4369         if ((!had_directory) && (had_device == NULL))
4370             {
4371             if (NULL == (devdir = strrchr(string, ']')))
4372                 devdir = strrchr(string, '>');
4373             strcpy(string, devdir + 1);
4374             }
4375         /*
4376          * Be consistent with what the C RTL has already done to the rest of
4377          * the argv items and lowercase all of these names.
4378          */
4379         for (c = string; *c; ++c)
4380             if (isupper(*c))
4381                 *c = tolower(*c);
4382         if (isunix) trim_unixpath(string,item,1);
4383         add_item(head, tail, string, count);
4384         ++expcount;
4385         }
4386     if (sts != RMS$_NMF)
4387         {
4388         set_vaxc_errno(sts);
4389         switch (sts)
4390             {
4391             case RMS$_FNF: case RMS$_DNF:
4392                 set_errno(ENOENT); break;
4393             case RMS$_DIR:
4394                 set_errno(ENOTDIR); break;
4395             case RMS$_DEV:
4396                 set_errno(ENODEV); break;
4397             case RMS$_FNM: case RMS$_SYN:
4398                 set_errno(EINVAL); break;
4399             case RMS$_PRV:
4400                 set_errno(EACCES); break;
4401             default:
4402                 _ckvmssts_noperl(sts);
4403             }
4404         }
4405     if (expcount == 0)
4406         add_item(head, tail, item, count);
4407     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4408     _ckvmssts_noperl(lib$find_file_end(&context));
4409 }
4410
4411 static int child_st[2];/* Event Flag set when child process completes   */
4412
4413 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
4414
4415 static unsigned long int exit_handler(int *status)
4416 {
4417 short iosb[4];
4418
4419     if (0 == child_st[0])
4420         {
4421 #ifdef ARGPROC_DEBUG
4422         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4423 #endif
4424         fflush(stdout);     /* Have to flush pipe for binary data to    */
4425                             /* terminate properly -- <tp@mccall.com>    */
4426         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4427         sys$dassgn(child_chan);
4428         fclose(stdout);
4429         sys$synch(0, child_st);
4430         }
4431     return(1);
4432 }
4433
4434 static void sig_child(int chan)
4435 {
4436 #ifdef ARGPROC_DEBUG
4437     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4438 #endif
4439     if (child_st[0] == 0)
4440         child_st[0] = 1;
4441 }
4442
4443 static struct exit_control_block exit_block =
4444     {
4445     0,
4446     exit_handler,
4447     1,
4448     &exit_block.exit_status,
4449     0
4450     };
4451
4452 static void
4453 pipe_and_fork(pTHX_ char **cmargv)
4454 {
4455     PerlIO *fp;
4456     struct dsc$descriptor_s *vmscmd;
4457     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4458     int sts, j, l, ismcr, quote, tquote = 0;
4459
4460     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
4461     vms_execfree(vmscmd);
4462
4463     j = l = 0;
4464     p = subcmd;
4465     q = cmargv[0];
4466     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
4467               && toupper(*(q+2)) == 'R' && !*(q+3);
4468
4469     while (q && l < MAX_DCL_LINE_LENGTH) {
4470         if (!*q) {
4471             if (j > 0 && quote) {
4472                 *p++ = '"';
4473                 l++;
4474             }
4475             q = cmargv[++j];
4476             if (q) {
4477                 if (ismcr && j > 1) quote = 1;
4478                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
4479                 *p++ = ' ';
4480                 l++;
4481                 if (quote || tquote) {
4482                     *p++ = '"';
4483                     l++;
4484                 }
4485         }
4486         } else {
4487             if ((quote||tquote) && *q == '"') {
4488                 *p++ = '"';
4489                 l++;
4490         }
4491             *p++ = *q++;
4492             l++;
4493         }
4494     }
4495     *p = '\0';
4496
4497     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4498     if (fp == Nullfp) {
4499         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4500         }
4501 }
4502
4503 static int background_process(pTHX_ int argc, char **argv)
4504 {
4505 char command[2048] = "$";
4506 $DESCRIPTOR(value, "");
4507 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4508 static $DESCRIPTOR(null, "NLA0:");
4509 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4510 char pidstring[80];
4511 $DESCRIPTOR(pidstr, "");
4512 int pid;
4513 unsigned long int flags = 17, one = 1, retsts;
4514
4515     strcat(command, argv[0]);
4516     while (--argc)
4517         {
4518         strcat(command, " \"");
4519         strcat(command, *(++argv));
4520         strcat(command, "\"");
4521         }
4522     value.dsc$a_pointer = command;
4523     value.dsc$w_length = strlen(value.dsc$a_pointer);
4524     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4525     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4526     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4527         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4528     }
4529     else {
4530         _ckvmssts_noperl(retsts);
4531     }
4532 #ifdef ARGPROC_DEBUG
4533     PerlIO_printf(Perl_debug_log, "%s\n", command);
4534 #endif
4535     sprintf(pidstring, "%08X", pid);
4536     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4537     pidstr.dsc$a_pointer = pidstring;
4538     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4539     lib$set_symbol(&pidsymbol, &pidstr);
4540     return(SS$_NORMAL);
4541 }
4542 /*}}}*/
4543 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4544
4545
4546 /* OS-specific initialization at image activation (not thread startup) */
4547 /* Older VAXC header files lack these constants */
4548 #ifndef JPI$_RIGHTS_SIZE
4549 #  define JPI$_RIGHTS_SIZE 817
4550 #endif
4551 #ifndef KGB$M_SUBSYSTEM
4552 #  define KGB$M_SUBSYSTEM 0x8
4553 #endif
4554
4555 /*{{{void vms_image_init(int *, char ***)*/
4556 void
4557 vms_image_init(int *argcp, char ***argvp)
4558 {
4559   char eqv[LNM$C_NAMLENGTH+1] = "";
4560   unsigned int len, tabct = 8, tabidx = 0;
4561   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4562   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4563   unsigned short int dummy, rlen;
4564   struct dsc$descriptor_s **tabvec;
4565 #if defined(PERL_IMPLICIT_CONTEXT)
4566   pTHX = NULL;
4567 #endif
4568   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
4569                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
4570                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4571                                  {          0,                0,    0,      0} };
4572
4573 #ifdef KILL_BY_SIGPRC
4574     (void) Perl_csighandler_init();
4575 #endif
4576
4577   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4578   _ckvmssts_noperl(iosb[0]);
4579   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4580     if (iprv[i]) {           /* Running image installed with privs? */
4581       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
4582       will_taint = TRUE;
4583       break;
4584     }
4585   }
4586   /* Rights identifiers might trigger tainting as well. */
4587   if (!will_taint && (rlen || rsz)) {
4588     while (rlen < rsz) {
4589       /* We didn't get all the identifiers on the first pass.  Allocate a
4590        * buffer much larger than $GETJPI wants (rsz is size in bytes that
4591        * were needed to hold all identifiers at time of last call; we'll
4592        * allocate that many unsigned long ints), and go back and get 'em.
4593        * If it gave us less than it wanted to despite ample buffer space,
4594        * something's broken.  Is your system missing a system identifier?
4595        */
4596       if (rsz <= jpilist[1].buflen) {
4597          /* Perl_croak accvios when used this early in startup. */
4598          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4599                          rsz, (unsigned long) jpilist[1].buflen,
4600                          "Check your rights database for corruption.\n");
4601          exit(SS$_ABORT);
4602       }
4603       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4604       jpilist[1].bufadr = Newx(mask,rsz,unsigned long int);
4605       jpilist[1].buflen = rsz * sizeof(unsigned long int);
4606       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4607       _ckvmssts_noperl(iosb[0]);
4608     }
4609     mask = jpilist[1].bufadr;
4610     /* Check attribute flags for each identifier (2nd longword); protected
4611      * subsystem identifiers trigger tainting.
4612      */
4613     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4614       if (mask[i] & KGB$M_SUBSYSTEM) {
4615         will_taint = TRUE;
4616         break;
4617       }
4618     }
4619     if (mask != rlst) Safefree(mask);
4620   }
4621   /* We need to use this hack to tell Perl it should run with tainting,
4622    * since its tainting flag may be part of the PL_curinterp struct, which
4623    * hasn't been allocated when vms_image_init() is called.
4624    */
4625   if (will_taint) {
4626     char **newargv, **oldargv;
4627     oldargv = *argvp;
4628     Newx(newargv,(*argcp)+2,char *);
4629     newargv[0] = oldargv[0];
4630     Newx(newargv[1],3,char);
4631     strcpy(newargv[1], "-T");
4632     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
4633     (*argcp)++;
4634     newargv[*argcp] = NULL;
4635     /* We orphan the old argv, since we don't know where it's come from,
4636      * so we don't know how to free it.
4637      */
4638     *argvp = newargv;
4639   }
4640   else {  /* Did user explicitly request tainting? */
4641     int i;
4642     char *cp, **av = *argvp;
4643     for (i = 1; i < *argcp; i++) {
4644       if (*av[i] != '-') break;
4645       for (cp = av[i]+1; *cp; cp++) {
4646         if (*cp == 'T') { will_taint = 1; break; }
4647         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4648                   strchr("DFIiMmx",*cp)) break;
4649       }
4650       if (will_taint) break;
4651     }
4652   }
4653
4654   for (tabidx = 0;
4655        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4656        tabidx++) {
4657     if (!tabidx) Newx(tabvec,tabct,struct dsc$descriptor_s *);
4658     else if (tabidx >= tabct) {
4659       tabct += 8;
4660       Renew(tabvec,tabct,struct dsc$descriptor_s *);
4661     }
4662     Newx(tabvec[tabidx],1,struct dsc$descriptor_s);
4663     tabvec[tabidx]->dsc$w_length  = 0;
4664     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
4665     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
4666     tabvec[tabidx]->dsc$a_pointer = NULL;
4667     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4668   }
4669   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4670
4671   getredirection(argcp,argvp);
4672 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
4673   {
4674 # include <reentrancy.h>
4675   (void) decc$set_reentrancy(C$C_MULTITHREAD);
4676   }
4677 #endif
4678   return;
4679 }
4680 /*}}}*/
4681
4682
4683 /* trim_unixpath()
4684  * Trim Unix-style prefix off filespec, so it looks like what a shell
4685  * glob expansion would return (i.e. from specified prefix on, not
4686  * full path).  Note that returned filespec is Unix-style, regardless
4687  * of whether input filespec was VMS-style or Unix-style.
4688  *
4689  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4690  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
4691  * vector of options; at present, only bit 0 is used, and if set tells
4692  * trim unixpath to try the current default directory as a prefix when
4693  * presented with a possibly ambiguous ... wildcard.
4694  *
4695  * Returns !=0 on success, with trimmed filespec replacing contents of
4696  * fspec, and 0 on failure, with contents of fpsec unchanged.
4697  */
4698 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4699 int
4700 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4701 {
4702   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4703        *template, *base, *end, *cp1, *cp2;
4704   register int tmplen, reslen = 0, dirs = 0;
4705
4706   if (!wildspec || !fspec) return 0;
4707   if (strpbrk(wildspec,"]>:") != NULL) {
4708     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4709     else template = unixwild;
4710   }
4711   else template = wildspec;
4712   if (strpbrk(fspec,"]>:") != NULL) {
4713     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4714     else base = unixified;
4715     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4716      * check to see that final result fits into (isn't longer than) fspec */
4717     reslen = strlen(fspec);
4718   }
4719   else base = fspec;
4720
4721   /* No prefix or absolute path on wildcard, so nothing to remove */
4722   if (!*template || *template == '/') {
4723     if (base == fspec) return 1;
4724     tmplen = strlen(unixified);
4725     if (tmplen > reslen) return 0;  /* not enough space */
4726     /* Copy unixified resultant, including trailing NUL */
4727     memmove(fspec,unixified,tmplen+1);
4728     return 1;
4729   }
4730
4731   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
4732   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4733     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4734     for (cp1 = end ;cp1 >= base; cp1--)
4735       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4736         { cp1++; break; }
4737     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4738     return 1;
4739   }
4740   else {
4741     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4742     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4743     int ells = 1, totells, segdirs, match;
4744     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4745                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4746
4747     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4748     totells = ells;
4749     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4750     if (ellipsis == template && opts & 1) {
4751       /* Template begins with an ellipsis.  Since we can't tell how many
4752        * directory names at the front of the resultant to keep for an
4753        * arbitrary starting point, we arbitrarily choose the current
4754        * default directory as a starting point.  If it's there as a prefix,
4755        * clip it off.  If not, fall through and act as if the leading
4756        * ellipsis weren't there (i.e. return shortest possible path that
4757        * could match template).
4758        */
4759       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4760       for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4761         if (_tolower(*cp1) != _tolower(*cp2)) break;
4762       segdirs = dirs - totells;  /* Min # of dirs we must have left */
4763       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4764       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4765         memcpy(fspec,cp2+1,end - cp2);
4766         return 1;
4767       }
4768     }
4769     /* First off, back up over constant elements at end of path */
4770     if (dirs) {
4771       for (front = end ; front >= base; front--)
4772          if (*front == '/' && !dirs--) { front++; break; }
4773     }
4774     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4775          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
4776     if (cp1 != '\0') return 0;  /* Path too long. */
4777     lcend = cp2;
4778     *cp2 = '\0';  /* Pick up with memcpy later */
4779     lcfront = lcres + (front - base);
4780     /* Now skip over each ellipsis and try to match the path in front of it. */
4781     while (ells--) {
4782       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4783         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
4784             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
4785       if (cp1 < template) break; /* template started with an ellipsis */
4786       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4787         ellipsis = cp1; continue;
4788       }
4789       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4790       nextell = cp1;
4791       for (segdirs = 0, cp2 = tpl;
4792            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4793            cp1++, cp2++) {
4794          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4795          else *cp2 = _tolower(*cp1);  /* else lowercase for match */
4796          if (*cp2 == '/') segdirs++;
4797       }
4798       if (cp1 != ellipsis - 1) return 0; /* Path too long */
4799       /* Back up at least as many dirs as in template before matching */
4800       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4801         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4802       for (match = 0; cp1 > lcres;) {
4803         resdsc.dsc$a_pointer = cp1;
4804         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4805           match++;
4806           if (match == 1) lcfront = cp1;
4807         }
4808         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4809       }
4810       if (!match) return 0;  /* Can't find prefix ??? */
4811       if (match > 1 && opts & 1) {
4812         /* This ... wildcard could cover more than one set of dirs (i.e.
4813          * a set of similar dir names is repeated).  If the template
4814          * contains more than 1 ..., upstream elements could resolve the
4815          * ambiguity, but it's not worth a full backtracking setup here.
4816          * As a quick heuristic, clip off the current default directory
4817          * if it's present to find the trimmed spec, else use the
4818          * shortest string that this ... could cover.
4819          */
4820         char def[NAM$C_MAXRSS+1], *st;
4821
4822         if (getcwd(def, sizeof def,0) == NULL) return 0;
4823         for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4824           if (_tolower(*cp1) != _tolower(*cp2)) break;
4825         segdirs = dirs - totells;  /* Min # of dirs we must have left */
4826         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4827         if (*cp1 == '\0' && *cp2 == '/') {
4828           memcpy(fspec,cp2+1,end - cp2);
4829           return 1;
4830         }
4831         /* Nope -- stick with lcfront from above and keep going. */
4832       }
4833     }
4834     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4835     return 1;
4836     ellipsis = nextell;
4837   }
4838
4839 }  /* end of trim_unixpath() */
4840 /*}}}*/
4841
4842
4843 /*
4844  *  VMS readdir() routines.
4845  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4846  *
4847  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
4848  *  Minor modifications to original routines.
4849  */
4850
4851 /* readdir may have been redefined by reentr.h, so make sure we get
4852  * the local version for what we do here.
4853  */
4854 #ifdef readdir
4855 # undef readdir
4856 #endif
4857 #if !defined(PERL_IMPLICIT_CONTEXT)
4858 # define readdir Perl_readdir
4859 #else
4860 # define readdir(a) Perl_readdir(aTHX_ a)
4861 #endif
4862
4863     /* Number of elements in vms_versions array */
4864 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
4865
4866 /*
4867  *  Open a directory, return a handle for later use.
4868  */
4869 /*{{{ DIR *opendir(char*name) */
4870 DIR *
4871 Perl_opendir(pTHX_ const char *name)
4872 {
4873     DIR *dd;
4874     char dir[NAM$C_MAXRSS+1];
4875     Stat_t sb;
4876
4877     if (do_tovmspath(name,dir,0) == NULL) {
4878       return NULL;
4879     }
4880     /* Check access before stat; otherwise stat does not
4881      * accurately report whether it's a directory.
4882      */
4883     if (!cando_by_name(S_IRUSR,0,dir)) {
4884       /* cando_by_name has already set errno */
4885       return NULL;
4886     }
4887     if (flex_stat(dir,&sb) == -1) return NULL;
4888     if (!S_ISDIR(sb.st_mode)) {
4889       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
4890       return NULL;
4891     }
4892     /* Get memory for the handle, and the pattern. */
4893     Newx(dd,1,DIR);
4894     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4895
4896     /* Fill in the fields; mainly playing with the descriptor. */
4897     (void)sprintf(dd->pattern, "%s*.*",dir);
4898     dd->context = 0;
4899     dd->count = 0;
4900     dd->vms_wantversions = 0;
4901     dd->pat.dsc$a_pointer = dd->pattern;
4902     dd->pat.dsc$w_length = strlen(dd->pattern);
4903     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4904     dd->pat.dsc$b_class = DSC$K_CLASS_S;
4905 #if defined(USE_ITHREADS)
4906     Newx(dd->mutex,1,perl_mutex);
4907     MUTEX_INIT( (perl_mutex *) dd->mutex );
4908 #else
4909     dd->mutex = NULL;
4910 #endif
4911
4912     return dd;
4913 }  /* end of opendir() */
4914 /*}}}*/
4915
4916 /*
4917  *  Set the flag to indicate we want versions or not.
4918  */
4919 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4920 void
4921 vmsreaddirversions(DIR *dd, int flag)
4922 {
4923     dd->vms_wantversions = flag;
4924 }
4925 /*}}}*/
4926
4927 /*
4928  *  Free up an opened directory.
4929  */
4930 /*{{{ void closedir(DIR *dd)*/
4931 void
4932 closedir(DIR *dd)
4933 {
4934     (void)lib$find_file_end(&dd->context);
4935     Safefree(dd->pattern);
4936 #if defined(USE_ITHREADS)
4937     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
4938     Safefree(dd->mutex);
4939 #endif
4940     Safefree((char *)dd);
4941 }
4942 /*}}}*/
4943
4944 /*
4945  *  Collect all the version numbers for the current file.
4946  */
4947 static void
4948 collectversions(pTHX_ DIR *dd)
4949 {
4950     struct dsc$descriptor_s     pat;
4951     struct dsc$descriptor_s     res;
4952     struct dirent *e;
4953     char *p, *text, buff[sizeof dd->entry.d_name];
4954     int i;
4955     unsigned long context, tmpsts;
4956
4957     /* Convenient shorthand. */
4958     e = &dd->entry;
4959
4960     /* Add the version wildcard, ignoring the "*.*" put on before */
4961     i = strlen(dd->pattern);
4962     Newx(text,i + e->d_namlen + 3,char);
4963     (void)strcpy(text, dd->pattern);
4964     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4965
4966     /* Set up the pattern descriptor. */
4967     pat.dsc$a_pointer = text;
4968     pat.dsc$w_length = i + e->d_namlen - 1;
4969     pat.dsc$b_dtype = DSC$K_DTYPE_T;
4970     pat.dsc$b_class = DSC$K_CLASS_S;
4971
4972     /* Set up result descriptor. */
4973     res.dsc$a_pointer = buff;
4974     res.dsc$w_length = sizeof buff - 2;
4975     res.dsc$b_dtype = DSC$K_DTYPE_T;
4976     res.dsc$b_class = DSC$K_CLASS_S;
4977
4978     /* Read files, collecting versions. */
4979     for (context = 0, e->vms_verscount = 0;
4980          e->vms_verscount < VERSIZE(e);
4981          e->vms_verscount++) {
4982         tmpsts = lib$find_file(&pat, &res, &context);
4983         if (tmpsts == RMS$_NMF || context == 0) break;
4984         _ckvmssts(tmpsts);
4985         buff[sizeof buff - 1] = '\0';
4986         if ((p = strchr(buff, ';')))
4987             e->vms_versions[e->vms_verscount] = atoi(p + 1);
4988         else
4989             e->vms_versions[e->vms_verscount] = -1;
4990     }
4991
4992     _ckvmssts(lib$find_file_end(&context));
4993     Safefree(text);
4994
4995 }  /* end of collectversions() */
4996
4997 /*
4998  *  Read the next entry from the directory.
4999  */
5000 /*{{{ struct dirent *readdir(DIR *dd)*/
5001 struct dirent *
5002 Perl_readdir(pTHX_ DIR *dd)
5003 {
5004     struct dsc$descriptor_s     res;
5005     char *p, buff[sizeof dd->entry.d_name];
5006     unsigned long int tmpsts;
5007
5008     /* Set up result descriptor, and get next file. */
5009     res.dsc$a_pointer = buff;
5010     res.dsc$w_length = sizeof buff - 2;
5011     res.dsc$b_dtype = DSC$K_DTYPE_T;
5012     res.dsc$b_class = DSC$K_CLASS_S;
5013     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
5014     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
5015     if (!(tmpsts & 1)) {
5016       set_vaxc_errno(tmpsts);
5017       switch (tmpsts) {
5018         case RMS$_PRV:
5019           set_errno(EACCES); break;
5020         case RMS$_DEV:
5021           set_errno(ENODEV); break;
5022         case RMS$_DIR:
5023           set_errno(ENOTDIR); break;
5024         case RMS$_FNF: case RMS$_DNF:
5025           set_errno(ENOENT); break;
5026         default:
5027           set_errno(EVMSERR);
5028       }
5029       return NULL;
5030     }
5031     dd->count++;
5032     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
5033     buff[sizeof buff - 1] = '\0';
5034     for (p = buff; *p; p++) *p = _tolower(*p);
5035     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
5036     *p = '\0';
5037
5038     /* Skip any directory component and just copy the name. */
5039     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
5040     else (void)strcpy(dd->entry.d_name, buff);
5041
5042     /* Clobber the version. */
5043     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
5044
5045     dd->entry.d_namlen = strlen(dd->entry.d_name);
5046     dd->entry.vms_verscount = 0;
5047     if (dd->vms_wantversions) collectversions(aTHX_ dd);
5048     return &dd->entry;
5049
5050 }  /* end of readdir() */
5051 /*}}}*/
5052
5053 /*
5054  *  Read the next entry from the directory -- thread-safe version.
5055  */
5056 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
5057 int
5058 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
5059 {
5060     int retval;
5061
5062     MUTEX_LOCK( (perl_mutex *) dd->mutex );
5063
5064     entry = readdir(dd);
5065     *result = entry;
5066     retval = ( *result == NULL ? errno : 0 );
5067
5068     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
5069
5070     return retval;
5071
5072 }  /* end of readdir_r() */
5073 /*}}}*/
5074
5075 /*
5076  *  Return something that can be used in a seekdir later.
5077  */
5078 /*{{{ long telldir(DIR *dd)*/
5079 long
5080 telldir(DIR *dd)
5081 {
5082     return dd->count;
5083 }
5084 /*}}}*/
5085
5086 /*
5087  *  Return to a spot where we used to be.  Brute force.
5088  */
5089 /*{{{ void seekdir(DIR *dd,long count)*/
5090 void
5091 Perl_seekdir(pTHX_ DIR *dd, long count)
5092 {
5093     int vms_wantversions;
5094
5095     /* If we haven't done anything yet... */
5096     if (dd->count == 0)
5097         return;
5098
5099     /* Remember some state, and clear it. */
5100     vms_wantversions = dd->vms_wantversions;
5101     dd->vms_wantversions = 0;
5102     _ckvmssts(lib$find_file_end(&dd->context));
5103     dd->context = 0;
5104
5105     /* The increment is in readdir(). */
5106     for (dd->count = 0; dd->count < count; )
5107         (void)readdir(dd);
5108
5109     dd->vms_wantversions = vms_wantversions;
5110
5111 }  /* end of seekdir() */
5112 /*}}}*/
5113
5114 /* VMS subprocess management
5115  *
5116  * my_vfork() - just a vfork(), after setting a flag to record that
5117  * the current script is trying a Unix-style fork/exec.
5118  *
5119  * vms_do_aexec() and vms_do_exec() are called in response to the
5120  * perl 'exec' function.  If this follows a vfork call, then they
5121  * call out the regular perl routines in doio.c which do an
5122  * execvp (for those who really want to try this under VMS).
5123  * Otherwise, they do exactly what the perl docs say exec should
5124  * do - terminate the current script and invoke a new command
5125  * (See below for notes on command syntax.)
5126  *
5127  * do_aspawn() and do_spawn() implement the VMS side of the perl
5128  * 'system' function.
5129  *
5130  * Note on command arguments to perl 'exec' and 'system': When handled
5131  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
5132  * are concatenated to form a DCL command string.  If the first arg
5133  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
5134  * the command string is handed off to DCL directly.  Otherwise,
5135  * the first token of the command is taken as the filespec of an image
5136  * to run.  The filespec is expanded using a default type of '.EXE' and
5137  * the process defaults for device, directory, etc., and if found, the resultant
5138  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
5139  * the command string as parameters.  This is perhaps a bit complicated,
5140  * but I hope it will form a happy medium between what VMS folks expect
5141  * from lib$spawn and what Unix folks expect from exec.
5142  */
5143
5144 static int vfork_called;
5145
5146 /*{{{int my_vfork()*/
5147 int
5148 my_vfork()
5149 {
5150   vfork_called++;
5151   return vfork();
5152 }
5153 /*}}}*/
5154
5155
5156 static void
5157 vms_execfree(struct dsc$descriptor_s *vmscmd)
5158 {
5159   if (vmscmd) {
5160       if (vmscmd->dsc$a_pointer) {
5161           Safefree(vmscmd->dsc$a_pointer);
5162       }
5163       Safefree(vmscmd);
5164   }
5165 }
5166
5167 static char *
5168 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
5169 {
5170   char *junk, *tmps = Nullch;
5171   register size_t cmdlen = 0;
5172   size_t rlen;
5173   register SV **idx;
5174   STRLEN n_a;
5175
5176   idx = mark;
5177   if (really) {
5178     tmps = SvPV(really,rlen);
5179     if (*tmps) {
5180       cmdlen += rlen + 1;
5181       idx++;
5182     }
5183   }
5184
5185   for (idx++; idx <= sp; idx++) {
5186     if (*idx) {
5187       junk = SvPVx(*idx,rlen);
5188       cmdlen += rlen ? rlen + 1 : 0;
5189     }
5190   }
5191   Newx(PL_Cmd,cmdlen+1,char);
5192
5193   if (tmps && *tmps) {
5194     strcpy(PL_Cmd,tmps);
5195     mark++;
5196   }
5197   else *PL_Cmd = '\0';
5198   while (++mark <= sp) {
5199     if (*mark) {
5200       char *s = SvPVx(*mark,n_a);
5201       if (!*s) continue;
5202       if (*PL_Cmd) strcat(PL_Cmd," ");
5203       strcat(PL_Cmd,s);
5204     }
5205   }
5206   return PL_Cmd;
5207
5208 }  /* end of setup_argstr() */
5209
5210
5211 static unsigned long int
5212 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5213                    struct dsc$descriptor_s **pvmscmd)
5214 {
5215   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5216   $DESCRIPTOR(defdsc,".EXE");
5217   $DESCRIPTOR(defdsc2,".");
5218   $DESCRIPTOR(resdsc,resspec);
5219   struct dsc$descriptor_s *vmscmd;
5220   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5221   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5222   register char *s, *rest, *cp, *wordbreak;
5223   register int isdcl;
5224
5225   Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5226   vmscmd->dsc$a_pointer = NULL;
5227   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
5228   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
5229   vmscmd->dsc$w_length = 0;
5230   if (pvmscmd) *pvmscmd = vmscmd;
5231
5232   if (suggest_quote) *suggest_quote = 0;
5233
5234   if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5235     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
5236   s = cmd;
5237   while (*s && isspace(*s)) s++;
5238
5239   if (*s == '@' || *s == '$') {
5240     vmsspec[0] = *s;  rest = s + 1;
5241     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5242   }
5243   else { cp = vmsspec; rest = s; }
5244   if (*rest == '.' || *rest == '/') {
5245     char *cp2;
5246     for (cp2 = resspec;
5247          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5248          rest++, cp2++) *cp2 = *rest;
5249     *cp2 = '\0';
5250     if (do_tovmsspec(resspec,cp,0)) {
5251       s = vmsspec;
5252       if (*rest) {
5253         for (cp2 = vmsspec + strlen(vmsspec);
5254              *rest && cp2 - vmsspec < sizeof vmsspec;
5255              rest++, cp2++) *cp2 = *rest;
5256         *cp2 = '\0';
5257       }
5258     }
5259   }
5260   /* Intuit whether verb (first word of cmd) is a DCL command:
5261    *   - if first nonspace char is '@', it's a DCL indirection
5262    * otherwise
5263    *   - if verb contains a filespec separator, it's not a DCL command
5264    *   - if it doesn't, caller tells us whether to default to a DCL
5265    *     command, or to a local image unless told it's DCL (by leading '$')
5266    */
5267   if (*s == '@') {
5268       isdcl = 1;
5269       if (suggest_quote) *suggest_quote = 1;
5270   } else {
5271     register char *filespec = strpbrk(s,":<[.;");
5272     rest = wordbreak = strpbrk(s," \"\t/");
5273     if (!wordbreak) wordbreak = s + strlen(s);
5274     if (*s == '$') check_img = 0;
5275     if (filespec && (filespec < wordbreak)) isdcl = 0;
5276     else isdcl = !check_img;
5277   }
5278
5279   if (!isdcl) {
5280     imgdsc.dsc$a_pointer = s;
5281     imgdsc.dsc$w_length = wordbreak - s;
5282     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5283     if (!(retsts&1)) {
5284         _ckvmssts(lib$find_file_end(&cxt));
5285         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5286     if (!(retsts & 1) && *s == '$') {
5287           _ckvmssts(lib$find_file_end(&cxt));
5288       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5289       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5290           if (!(retsts&1)) {
5291       _ckvmssts(lib$find_file_end(&cxt));
5292             retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5293           }
5294     }
5295     }
5296     _ckvmssts(lib$find_file_end(&cxt));
5297
5298     if (retsts & 1) {
5299       FILE *fp;
5300       s = resspec;
5301       while (*s && !isspace(*s)) s++;
5302       *s = '\0';
5303
5304       /* check that it's really not DCL with no file extension */
5305       fp = fopen(resspec,"r","ctx=bin","shr=get");
5306       if (fp) {
5307         char b[4] = {0,0,0,0};
5308         read(fileno(fp),b,4);
5309         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5310         fclose(fp);
5311       }
5312       if (check_img && isdcl) return RMS$_FNF;
5313
5314       if (cando_by_name(S_IXUSR,0,resspec)) {
5315         Newx(vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5316         if (!isdcl) {
5317             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5318             if (suggest_quote) *suggest_quote = 1;
5319         } else {
5320             strcpy(vmscmd->dsc$a_pointer,"@");
5321             if (suggest_quote) *suggest_quote = 1;
5322         }
5323         strcat(vmscmd->dsc$a_pointer,resspec);
5324         if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5325         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5326         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5327       }
5328       else retsts = RMS$_PRV;
5329     }
5330   }
5331   /* It's either a DCL command or we couldn't find a suitable image */
5332   vmscmd->dsc$w_length = strlen(cmd);
5333 /*  if (cmd == PL_Cmd) {
5334       vmscmd->dsc$a_pointer = PL_Cmd;
5335       if (suggest_quote) *suggest_quote = 1;
5336   }
5337   else  */
5338       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5339
5340   /* check if it's a symbol (for quoting purposes) */
5341   if (suggest_quote && !*suggest_quote) {
5342     int iss;
5343     char equiv[LNM$C_NAMLENGTH];
5344     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5345     eqvdsc.dsc$a_pointer = equiv;
5346
5347     iss = lib$get_symbol(vmscmd,&eqvdsc);
5348     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5349   }
5350   if (!(retsts & 1)) {
5351     /* just hand off status values likely to be due to user error */
5352     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5353         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5354        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5355     else { _ckvmssts(retsts); }
5356   }
5357
5358   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5359
5360 }  /* end of setup_cmddsc() */
5361
5362
5363 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5364 bool
5365 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5366 {
5367   if (sp > mark) {
5368     if (vfork_called) {           /* this follows a vfork - act Unixish */
5369       vfork_called--;
5370       if (vfork_called < 0) {
5371         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5372         vfork_called = 0;
5373       }
5374       else return do_aexec(really,mark,sp);
5375     }
5376                                            /* no vfork - act VMSish */
5377     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5378
5379   }
5380
5381   return FALSE;
5382 }  /* end of vms_do_aexec() */
5383 /*}}}*/
5384
5385 /* {{{bool vms_do_exec(char *cmd) */
5386 bool
5387 Perl_vms_do_exec(pTHX_ char *cmd)
5388 {
5389   struct dsc$descriptor_s *vmscmd;
5390
5391   if (vfork_called) {             /* this follows a vfork - act Unixish */
5392     vfork_called--;
5393     if (vfork_called < 0) {
5394       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5395       vfork_called = 0;
5396     }
5397     else return do_exec(cmd);
5398   }
5399
5400   {                               /* no vfork - act VMSish */
5401     unsigned long int retsts;
5402
5403     TAINT_ENV();
5404     TAINT_PROPER("exec");
5405     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5406       retsts = lib$do_command(vmscmd);
5407
5408     switch (retsts) {
5409       case RMS$_FNF: case RMS$_DNF:
5410         set_errno(ENOENT); break;
5411       case RMS$_DIR:
5412         set_errno(ENOTDIR); break;
5413       case RMS$_DEV:
5414         set_errno(ENODEV); break;
5415       case RMS$_PRV:
5416         set_errno(EACCES); break;
5417       case RMS$_SYN:
5418         set_errno(EINVAL); break;
5419       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5420         set_errno(E2BIG); break;
5421       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5422         _ckvmssts(retsts); /* fall through */
5423       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5424         set_errno(EVMSERR);
5425     }
5426     set_vaxc_errno(retsts);
5427     if (ckWARN(WARN_EXEC)) {
5428       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5429              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5430     }
5431     vms_execfree(vmscmd);
5432   }
5433
5434   return FALSE;
5435
5436 }  /* end of vms_do_exec() */
5437 /*}}}*/
5438
5439 unsigned long int Perl_do_spawn(pTHX_ char *);
5440
5441 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5442 unsigned long int
5443 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5444 {
5445   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5446
5447   return SS$_ABORT;
5448 }  /* end of do_aspawn() */
5449 /*}}}*/
5450
5451 /* {{{unsigned long int do_spawn(char *cmd) */
5452 unsigned long int
5453 Perl_do_spawn(pTHX_ char *cmd)
5454 {
5455   unsigned long int sts, substs;
5456
5457   TAINT_ENV();
5458   TAINT_PROPER("spawn");
5459   if (!cmd || !*cmd) {
5460     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5461     if (!(sts & 1)) {
5462       switch (sts) {
5463         case RMS$_FNF:  case RMS$_DNF:
5464           set_errno(ENOENT); break;
5465         case RMS$_DIR:
5466           set_errno(ENOTDIR); break;
5467         case RMS$_DEV:
5468           set_errno(ENODEV); break;
5469         case RMS$_PRV:
5470           set_errno(EACCES); break;
5471         case RMS$_SYN:
5472           set_errno(EINVAL); break;
5473         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5474           set_errno(E2BIG); break;
5475         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5476           _ckvmssts(sts); /* fall through */
5477         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5478           set_errno(EVMSERR);
5479       }
5480       set_vaxc_errno(sts);
5481       if (ckWARN(WARN_EXEC)) {
5482         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5483                     Strerror(errno));
5484       }
5485     }
5486     sts = substs;
5487   }
5488   else {
5489     (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5490   }
5491   return sts;
5492 }  /* end of do_spawn() */
5493 /*}}}*/
5494
5495
5496 static unsigned int *sockflags, sockflagsize;
5497
5498 /*
5499  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5500  * routines found in some versions of the CRTL can't deal with sockets.
5501  * We don't shim the other file open routines since a socket isn't
5502  * likely to be opened by a name.
5503  */
5504 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5505 FILE *my_fdopen(int fd, const char *mode)
5506 {
5507   FILE *fp = fdopen(fd, (char *) mode);
5508
5509   if (fp) {
5510     unsigned int fdoff = fd / sizeof(unsigned int);
5511     struct stat sbuf; /* native stat; we don't need flex_stat */
5512     if (!sockflagsize || fdoff > sockflagsize) {
5513       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
5514       else           Newx  (sockflags,fdoff+2,unsigned int);
5515       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5516       sockflagsize = fdoff + 2;
5517     }
5518     if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5519       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5520   }
5521   return fp;
5522
5523 }
5524 /*}}}*/
5525
5526
5527 /*
5528  * Clear the corresponding bit when the (possibly) socket stream is closed.
5529  * There still a small hole: we miss an implicit close which might occur
5530  * via freopen().  >> Todo
5531  */
5532 /*{{{ int my_fclose(FILE *fp)*/
5533 int my_fclose(FILE *fp) {
5534   if (fp) {
5535     unsigned int fd = fileno(fp);
5536     unsigned int fdoff = fd / sizeof(unsigned int);
5537
5538     if (sockflagsize && fdoff <= sockflagsize)
5539       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5540   }
5541   return fclose(fp);
5542 }
5543 /*}}}*/
5544
5545
5546 /*
5547  * A simple fwrite replacement which outputs itmsz*nitm chars without
5548  * introducing record boundaries every itmsz chars.
5549  * We are using fputs, which depends on a terminating null.  We may
5550  * well be writing binary data, so we need to accommodate not only
5551  * data with nulls sprinkled in the middle but also data with no null
5552  * byte at the end.
5553  */
5554 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5555 int
5556 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5557 {
5558   register char *cp, *end, *cpd, *data;
5559   register unsigned int fd = fileno(dest);
5560   register unsigned int fdoff = fd / sizeof(unsigned int);
5561   int retval;
5562   int bufsize = itmsz * nitm + 1;
5563
5564   if (fdoff < sockflagsize &&
5565       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5566     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5567     return nitm;
5568   }
5569
5570   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5571   memcpy( data, src, itmsz*nitm );
5572   data[itmsz*nitm] = '\0';
5573
5574   end = data + itmsz * nitm;
5575   retval = (int) nitm; /* on success return # items written */
5576
5577   cpd = data;
5578   while (cpd <= end) {
5579     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5580     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5581     if (cp < end)
5582       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5583     cpd = cp + 1;
5584   }
5585
5586   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5587   return retval;
5588
5589 }  /* end of my_fwrite() */
5590 /*}}}*/
5591
5592 /*{{{ int my_flush(FILE *fp)*/
5593 int
5594 Perl_my_flush(pTHX_ FILE *fp)
5595 {
5596     int res;
5597     if ((res = fflush(fp)) == 0 && fp) {
5598 #ifdef VMS_DO_SOCKETS
5599         Stat_t s;
5600         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5601 #endif
5602             res = fsync(fileno(fp));
5603     }
5604 /*
5605  * If the flush succeeded but set end-of-file, we need to clear
5606  * the error because our caller may check ferror().  BTW, this
5607  * probably means we just flushed an empty file.
5608  */
5609     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5610
5611     return res;
5612 }
5613 /*}}}*/
5614
5615 /*
5616  * Here are replacements for the following Unix routines in the VMS environment:
5617  *      getpwuid    Get information for a particular UIC or UID
5618  *      getpwnam    Get information for a named user
5619  *      getpwent    Get information for each user in the rights database
5620  *      setpwent    Reset search to the start of the rights database
5621  *      endpwent    Finish searching for users in the rights database
5622  *
5623  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5624  * (defined in pwd.h), which contains the following fields:-
5625  *      struct passwd {
5626  *              char        *pw_name;    Username (in lower case)
5627  *              char        *pw_passwd;  Hashed password
5628  *              unsigned int pw_uid;     UIC
5629  *              unsigned int pw_gid;     UIC group  number
5630  *              char        *pw_unixdir; Default device/directory (VMS-style)
5631  *              char        *pw_gecos;   Owner name
5632  *              char        *pw_dir;     Default device/directory (Unix-style)
5633  *              char        *pw_shell;   Default CLI name (eg. DCL)
5634  *      };
5635  * If the specified user does not exist, getpwuid and getpwnam return NULL.
5636  *
5637  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5638  * not the UIC member number (eg. what's returned by getuid()),
5639  * getpwuid() can accept either as input (if uid is specified, the caller's
5640  * UIC group is used), though it won't recognise gid=0.
5641  *
5642  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5643  * information about other users in your group or in other groups, respectively.
5644  * If the required privilege is not available, then these routines fill only
5645  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5646  * string).
5647  *
5648  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5649  */
5650
5651 /* sizes of various UAF record fields */
5652 #define UAI$S_USERNAME 12
5653 #define UAI$S_IDENT    31
5654 #define UAI$S_OWNER    31
5655 #define UAI$S_DEFDEV   31
5656 #define UAI$S_DEFDIR   63
5657 #define UAI$S_DEFCLI   31
5658 #define UAI$S_PWD       8
5659
5660 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
5661                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5662                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
5663
5664 static char __empty[]= "";
5665 static struct passwd __passwd_empty=
5666     {(char *) __empty, (char *) __empty, 0, 0,
5667      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5668 static int contxt= 0;
5669 static struct passwd __pwdcache;
5670 static char __pw_namecache[UAI$S_IDENT+1];
5671
5672 /*
5673  * This routine does most of the work extracting the user information.
5674  */
5675 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5676 {
5677     static struct {
5678         unsigned char length;
5679         char pw_gecos[UAI$S_OWNER+1];
5680     } owner;
5681     static union uicdef uic;
5682     static struct {
5683         unsigned char length;
5684         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5685     } defdev;
5686     static struct {
5687         unsigned char length;
5688         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5689     } defdir;
5690     static struct {
5691         unsigned char length;
5692         char pw_shell[UAI$S_DEFCLI+1];
5693     } defcli;
5694     static char pw_passwd[UAI$S_PWD+1];
5695
5696     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5697     struct dsc$descriptor_s name_desc;
5698     unsigned long int sts;
5699
5700     static struct itmlst_3 itmlst[]= {
5701         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
5702         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
5703         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
5704         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
5705         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
5706         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
5707         {0,                0,           NULL,    NULL}};
5708
5709     name_desc.dsc$w_length=  strlen(name);
5710     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5711     name_desc.dsc$b_class=   DSC$K_CLASS_S;
5712     name_desc.dsc$a_pointer= (char *) name;
5713
5714 /*  Note that sys$getuai returns many fields as counted strings. */
5715     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5716     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5717       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5718     }
5719     else { _ckvmssts(sts); }
5720     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
5721
5722     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
5723     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5724     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5725     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5726     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5727     owner.pw_gecos[lowner]=            '\0';
5728     defdev.pw_dir[ldefdev+ldefdir]= '\0';
5729     defcli.pw_shell[ldefcli]=          '\0';
5730     if (valid_uic(uic)) {
5731         pwd->pw_uid= uic.uic$l_uic;
5732         pwd->pw_gid= uic.uic$v_group;
5733     }
5734     else
5735       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5736     pwd->pw_passwd=  pw_passwd;
5737     pwd->pw_gecos=   owner.pw_gecos;
5738     pwd->pw_dir=     defdev.pw_dir;
5739     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5740     pwd->pw_shell=   defcli.pw_shell;
5741     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5742         int ldir;
5743         ldir= strlen(pwd->pw_unixdir) - 1;
5744         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5745     }
5746     else
5747         strcpy(pwd->pw_unixdir, pwd->pw_dir);
5748     __mystrtolower(pwd->pw_unixdir);
5749     return 1;
5750 }
5751
5752 /*
5753  * Get information for a named user.
5754 */
5755 /*{{{struct passwd *getpwnam(char *name)*/
5756 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5757 {
5758     struct dsc$descriptor_s name_desc;
5759     union uicdef uic;
5760     unsigned long int status, sts;
5761
5762     __pwdcache = __passwd_empty;
5763     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5764       /* We still may be able to determine pw_uid and pw_gid */
5765       name_desc.dsc$w_length=  strlen(name);
5766       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5767       name_desc.dsc$b_class=   DSC$K_CLASS_S;
5768       name_desc.dsc$a_pointer= (char *) name;
5769       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5770         __pwdcache.pw_uid= uic.uic$l_uic;
5771         __pwdcache.pw_gid= uic.uic$v_group;
5772       }
5773       else {
5774         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5775           set_vaxc_errno(sts);
5776           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5777           return NULL;
5778         }
5779         else { _ckvmssts(sts); }
5780       }
5781     }
5782     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5783     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5784     __pwdcache.pw_name= __pw_namecache;
5785     return &__pwdcache;
5786 }  /* end of my_getpwnam() */
5787 /*}}}*/
5788
5789 /*
5790  * Get information for a particular UIC or UID.
5791  * Called by my_getpwent with uid=-1 to list all users.
5792 */
5793 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5794 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5795 {
5796     const $DESCRIPTOR(name_desc,__pw_namecache);
5797     unsigned short lname;
5798     union uicdef uic;
5799     unsigned long int status;
5800
5801     if (uid == (unsigned int) -1) {
5802       do {
5803         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5804         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5805           set_vaxc_errno(status);
5806           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5807           my_endpwent();
5808           return NULL;
5809         }
5810         else { _ckvmssts(status); }
5811       } while (!valid_uic (uic));
5812     }
5813     else {
5814       uic.uic$l_uic= uid;
5815       if (!uic.uic$v_group)
5816         uic.uic$v_group= PerlProc_getgid();
5817       if (valid_uic(uic))
5818         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5819       else status = SS$_IVIDENT;
5820       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5821           status == RMS$_PRV) {
5822         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5823         return NULL;
5824       }
5825       else { _ckvmssts(status); }
5826     }
5827     __pw_namecache[lname]= '\0';
5828     __mystrtolower(__pw_namecache);
5829
5830     __pwdcache = __passwd_empty;
5831     __pwdcache.pw_name = __pw_namecache;
5832
5833 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5834     The identifier's value is usually the UIC, but it doesn't have to be,
5835     so if we can, we let fillpasswd update this. */
5836     __pwdcache.pw_uid =  uic.uic$l_uic;
5837     __pwdcache.pw_gid =  uic.uic$v_group;
5838
5839     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5840     return &__pwdcache;
5841
5842 }  /* end of my_getpwuid() */
5843 /*}}}*/
5844
5845 /*
5846  * Get information for next user.
5847 */
5848 /*{{{struct passwd *my_getpwent()*/
5849 struct passwd *Perl_my_getpwent(pTHX)
5850 {
5851     return (my_getpwuid((unsigned int) -1));
5852 }
5853 /*}}}*/
5854
5855 /*
5856  * Finish searching rights database for users.
5857 */
5858 /*{{{void my_endpwent()*/
5859 void Perl_my_endpwent(pTHX)
5860 {
5861     if (contxt) {
5862       _ckvmssts(sys$finish_rdb(&contxt));
5863       contxt= 0;
5864     }
5865 }
5866 /*}}}*/
5867
5868 #ifdef HOMEGROWN_POSIX_SIGNALS
5869   /* Signal handling routines, pulled into the core from POSIX.xs.
5870    *
5871    * We need these for threads, so they've been rolled into the core,
5872    * rather than left in POSIX.xs.
5873    *
5874    * (DRS, Oct 23, 1997)
5875    */
5876
5877   /* sigset_t is atomic under VMS, so these routines are easy */
5878 /*{{{int my_sigemptyset(sigset_t *) */
5879 int my_sigemptyset(sigset_t *set) {
5880     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5881     *set = 0; return 0;
5882 }
5883 /*}}}*/
5884
5885
5886 /*{{{int my_sigfillset(sigset_t *)*/
5887 int my_sigfillset(sigset_t *set) {
5888     int i;
5889     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5890     for (i = 0; i < NSIG; i++) *set |= (1 << i);
5891     return 0;
5892 }
5893 /*}}}*/
5894
5895
5896 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5897 int my_sigaddset(sigset_t *set, int sig) {
5898     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5899     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5900     *set |= (1 << (sig - 1));
5901     return 0;
5902 }
5903 /*}}}*/
5904
5905
5906 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5907 int my_sigdelset(sigset_t *set, int sig) {
5908     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5909     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5910     *set &= ~(1 << (sig - 1));
5911     return 0;
5912 }
5913 /*}}}*/
5914
5915
5916 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5917 int my_sigismember(sigset_t *set, int sig) {
5918     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5919     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5920     return *set & (1 << (sig - 1));
5921 }
5922 /*}}}*/
5923
5924
5925 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5926 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5927     sigset_t tempmask;
5928
5929     /* If set and oset are both null, then things are badly wrong. Bail out. */
5930     if ((oset == NULL) && (set == NULL)) {
5931       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5932       return -1;
5933     }
5934
5935     /* If set's null, then we're just handling a fetch. */
5936     if (set == NULL) {
5937         tempmask = sigblock(0);
5938     }
5939     else {
5940       switch (how) {
5941       case SIG_SETMASK:
5942         tempmask = sigsetmask(*set);
5943         break;
5944       case SIG_BLOCK:
5945         tempmask = sigblock(*set);
5946         break;
5947       case SIG_UNBLOCK:
5948         tempmask = sigblock(0);
5949         sigsetmask(*oset & ~tempmask);
5950         break;
5951       default:
5952         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5953         return -1;
5954       }
5955     }
5956
5957     /* Did they pass us an oset? If so, stick our holding mask into it */
5958     if (oset)
5959       *oset = tempmask;
5960
5961     return 0;
5962 }
5963 /*}}}*/
5964 #endif  /* HOMEGROWN_POSIX_SIGNALS */
5965
5966
5967 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5968  * my_utime(), and flex_stat(), all of which operate on UTC unless
5969  * VMSISH_TIMES is true.
5970  */
5971 /* method used to handle UTC conversions:
5972  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
5973  */
5974 static int gmtime_emulation_type;
5975 /* number of secs to add to UTC POSIX-style time to get local time */
5976 static long int utc_offset_secs;
5977
5978 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5979  * in vmsish.h.  #undef them here so we can call the CRTL routines
5980  * directly.
5981  */
5982 #undef gmtime
5983 #undef localtime
5984 #undef time
5985
5986
5987 /*
5988  * DEC C previous to 6.0 corrupts the behavior of the /prefix
5989  * qualifier with the extern prefix pragma.  This provisional
5990  * hack circumvents this prefix pragma problem in previous
5991  * precompilers.
5992  */
5993 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5994 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5995 #    pragma __extern_prefix save
5996 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
5997 #    define gmtime decc$__utctz_gmtime
5998 #    define localtime decc$__utctz_localtime
5999 #    define time decc$__utc_time
6000 #    pragma __extern_prefix restore
6001
6002      struct tm *gmtime(), *localtime();
6003
6004 #  endif
6005 #endif
6006
6007
6008 static time_t toutc_dst(time_t loc) {
6009   struct tm *rsltmp;
6010
6011   if ((rsltmp = localtime(&loc)) == NULL) return -1;
6012   loc -= utc_offset_secs;
6013   if (rsltmp->tm_isdst) loc -= 3600;
6014   return loc;
6015 }
6016 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
6017        ((gmtime_emulation_type || my_time(NULL)), \
6018        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
6019        ((secs) - utc_offset_secs))))
6020
6021 static time_t toloc_dst(time_t utc) {
6022   struct tm *rsltmp;
6023
6024   utc += utc_offset_secs;
6025   if ((rsltmp = localtime(&utc)) == NULL) return -1;
6026   if (rsltmp->tm_isdst) utc += 3600;
6027   return utc;
6028 }
6029 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
6030        ((gmtime_emulation_type || my_time(NULL)), \
6031        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
6032        ((secs) + utc_offset_secs))))
6033
6034 #ifndef RTL_USES_UTC
6035 /*
6036
6037     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
6038         DST starts on 1st sun of april      at 02:00  std time
6039             ends on last sun of october     at 02:00  dst time
6040     see the UCX management command reference, SET CONFIG TIMEZONE
6041     for formatting info.
6042
6043     No, it's not as general as it should be, but then again, NOTHING
6044     will handle UK times in a sensible way.
6045 */
6046
6047
6048 /*
6049     parse the DST start/end info:
6050     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
6051 */
6052
6053 static char *
6054 tz_parse_startend(char *s, struct tm *w, int *past)
6055 {
6056     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
6057     int ly, dozjd, d, m, n, hour, min, sec, j, k;
6058     time_t g;
6059
6060     if (!s)    return 0;
6061     if (!w) return 0;
6062     if (!past) return 0;
6063
6064     ly = 0;
6065     if (w->tm_year % 4        == 0) ly = 1;
6066     if (w->tm_year % 100      == 0) ly = 0;
6067     if (w->tm_year+1900 % 400 == 0) ly = 1;
6068     if (ly) dinm[1]++;
6069
6070     dozjd = isdigit(*s);
6071     if (*s == 'J' || *s == 'j' || dozjd) {
6072         if (!dozjd && !isdigit(*++s)) return 0;
6073         d = *s++ - '0';
6074         if (isdigit(*s)) {
6075             d = d*10 + *s++ - '0';
6076             if (isdigit(*s)) {
6077                 d = d*10 + *s++ - '0';
6078             }
6079         }
6080         if (d == 0) return 0;
6081         if (d > 366) return 0;
6082         d--;
6083         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
6084         g = d * 86400;
6085         dozjd = 1;
6086     } else if (*s == 'M' || *s == 'm') {
6087         if (!isdigit(*++s)) return 0;
6088         m = *s++ - '0';
6089         if (isdigit(*s)) m = 10*m + *s++ - '0';
6090         if (*s != '.') return 0;
6091         if (!isdigit(*++s)) return 0;
6092         n = *s++ - '0';
6093         if (n < 1 || n > 5) return 0;
6094         if (*s != '.') return 0;
6095         if (!isdigit(*++s)) return 0;
6096         d = *s++ - '0';
6097         if (d > 6) return 0;
6098     }
6099
6100     if (*s == '/') {
6101         if (!isdigit(*++s)) return 0;
6102         hour = *s++ - '0';
6103         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
6104         if (*s == ':') {
6105             if (!isdigit(*++s)) return 0;
6106             min = *s++ - '0';
6107             if (isdigit(*s)) min = 10*min + *s++ - '0';
6108             if (*s == ':') {
6109                 if (!isdigit(*++s)) return 0;
6110                 sec = *s++ - '0';
6111                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
6112             }
6113         }
6114     } else {
6115         hour = 2;
6116         min = 0;
6117         sec = 0;
6118     }
6119
6120     if (dozjd) {
6121         if (w->tm_yday < d) goto before;
6122         if (w->tm_yday > d) goto after;
6123     } else {
6124         if (w->tm_mon+1 < m) goto before;
6125         if (w->tm_mon+1 > m) goto after;
6126
6127         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
6128         k = d - j; /* mday of first d */
6129         if (k <= 0) k += 7;
6130         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
6131         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
6132         if (w->tm_mday < k) goto before;
6133         if (w->tm_mday > k) goto after;
6134     }
6135
6136     if (w->tm_hour < hour) goto before;
6137     if (w->tm_hour > hour) goto after;
6138     if (w->tm_min  < min)  goto before;
6139     if (w->tm_min  > min)  goto after;
6140     if (w->tm_sec  < sec)  goto before;
6141     goto after;
6142
6143 before:
6144     *past = 0;
6145     return s;
6146 after:
6147     *past = 1;
6148     return s;
6149 }
6150
6151
6152
6153
6154 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
6155
6156 static char *
6157 tz_parse_offset(char *s, int *offset)
6158 {
6159     int hour = 0, min = 0, sec = 0;
6160     int neg = 0;
6161     if (!s) return 0;
6162     if (!offset) return 0;
6163
6164     if (*s == '-') {neg++; s++;}
6165     if (*s == '+') s++;
6166     if (!isdigit(*s)) return 0;
6167     hour = *s++ - '0';
6168     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
6169     if (hour > 24) return 0;
6170     if (*s == ':') {
6171         if (!isdigit(*++s)) return 0;
6172         min = *s++ - '0';
6173         if (isdigit(*s)) min = min*10 + (*s++ - '0');
6174         if (min > 59) return 0;
6175         if (*s == ':') {
6176             if (!isdigit(*++s)) return 0;
6177             sec = *s++ - '0';
6178             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
6179             if (sec > 59) return 0;
6180         }
6181     }
6182
6183     *offset = (hour*60+min)*60 + sec;
6184     if (neg) *offset = -*offset;
6185     return s;
6186 }
6187
6188 /*
6189     input time is w, whatever type of time the CRTL localtime() uses.
6190     sets dst, the zone, and the gmtoff (seconds)
6191
6192     caches the value of TZ and UCX$TZ env variables; note that
6193     my_setenv looks for these and sets a flag if they're changed
6194     for efficiency.
6195
6196     We have to watch out for the "australian" case (dst starts in
6197     october, ends in april)...flagged by "reverse" and checked by
6198     scanning through the months of the previous year.
6199
6200 */
6201
6202 static int
6203 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
6204 {
6205     time_t when;
6206     struct tm *w2;
6207     char *s,*s2;
6208     char *dstzone, *tz, *s_start, *s_end;
6209     int std_off, dst_off, isdst;
6210     int y, dststart, dstend;
6211     static char envtz[1025];  /* longer than any logical, symbol, ... */
6212     static char ucxtz[1025];
6213     static char reversed = 0;
6214
6215     if (!w) return 0;
6216
6217     if (tz_updated) {
6218         tz_updated = 0;
6219         reversed = -1;  /* flag need to check  */
6220         envtz[0] = ucxtz[0] = '\0';
6221         tz = my_getenv("TZ",0);
6222         if (tz) strcpy(envtz, tz);
6223         tz = my_getenv("UCX$TZ",0);
6224         if (tz) strcpy(ucxtz, tz);
6225         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
6226     }
6227     tz = envtz;
6228     if (!*tz) tz = ucxtz;
6229
6230     s = tz;
6231     while (isalpha(*s)) s++;
6232     s = tz_parse_offset(s, &std_off);
6233     if (!s) return 0;
6234     if (!*s) {                  /* no DST, hurray we're done! */
6235         isdst = 0;
6236         goto done;
6237     }
6238
6239     dstzone = s;
6240     while (isalpha(*s)) s++;
6241     s2 = tz_parse_offset(s, &dst_off);
6242     if (s2) {
6243         s = s2;
6244     } else {
6245         dst_off = std_off - 3600;
6246     }
6247
6248     if (!*s) {      /* default dst start/end?? */
6249         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
6250             s = strchr(ucxtz,',');
6251         }
6252         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
6253     }
6254     if (*s != ',') return 0;
6255
6256     when = *w;
6257     when = _toutc(when);      /* convert to utc */
6258     when = when - std_off;    /* convert to pseudolocal time*/
6259
6260     w2 = localtime(&when);
6261     y = w2->tm_year;
6262     s_start = s+1;
6263     s = tz_parse_startend(s_start,w2,&dststart);
6264     if (!s) return 0;
6265     if (*s != ',') return 0;
6266
6267     when = *w;
6268     when = _toutc(when);      /* convert to utc */
6269     when = when - dst_off;    /* convert to pseudolocal time*/
6270     w2 = localtime(&when);
6271     if (w2->tm_year != y) {   /* spans a year, just check one time */
6272         when += dst_off - std_off;
6273         w2 = localtime(&when);
6274     }
6275     s_end = s+1;
6276     s = tz_parse_startend(s_end,w2,&dstend);
6277     if (!s) return 0;
6278
6279     if (reversed == -1) {  /* need to check if start later than end */
6280         int j, ds, de;
6281
6282         when = *w;
6283         if (when < 2*365*86400) {
6284             when += 2*365*86400;
6285         } else {
6286             when -= 365*86400;
6287         }
6288         w2 =localtime(&when);
6289         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
6290
6291         for (j = 0; j < 12; j++) {
6292             w2 =localtime(&when);
6293             (void) tz_parse_startend(s_start,w2,&ds);
6294             (void) tz_parse_startend(s_end,w2,&de);
6295             if (ds != de) break;
6296             when += 30*86400;
6297         }
6298         reversed = 0;
6299         if (de && !ds) reversed = 1;
6300     }
6301
6302     isdst = dststart && !dstend;
6303     if (reversed) isdst = dststart  || !dstend;
6304
6305 done:
6306     if (dst)    *dst = isdst;
6307     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6308     if (isdst)  tz = dstzone;
6309     if (zone) {
6310         while(isalpha(*tz))  *zone++ = *tz++;
6311         *zone = '\0';
6312     }
6313     return 1;
6314 }
6315
6316 #endif /* !RTL_USES_UTC */
6317
6318 /* my_time(), my_localtime(), my_gmtime()
6319  * By default traffic in UTC time values, using CRTL gmtime() or
6320  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6321  * Note: We need to use these functions even when the CRTL has working
6322  * UTC support, since they also handle C<use vmsish qw(times);>
6323  *
6324  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
6325  * Modified by Charles Bailey <bailey@newman.upenn.edu>
6326  */
6327
6328 /*{{{time_t my_time(time_t *timep)*/
6329 time_t Perl_my_time(pTHX_ time_t *timep)
6330 {
6331   time_t when;
6332   struct tm *tm_p;
6333
6334   if (gmtime_emulation_type == 0) {
6335     int dstnow;
6336     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
6337                               /* results of calls to gmtime() and localtime() */
6338                               /* for same &base */
6339
6340     gmtime_emulation_type++;
6341     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6342       char off[LNM$C_NAMLENGTH+1];;
6343
6344       gmtime_emulation_type++;
6345       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6346         gmtime_emulation_type++;
6347         utc_offset_secs = 0;
6348         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6349       }
6350       else { utc_offset_secs = atol(off); }
6351     }
6352     else { /* We've got a working gmtime() */
6353       struct tm gmt, local;
6354
6355       gmt = *tm_p;
6356       tm_p = localtime(&base);
6357       local = *tm_p;
6358       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
6359       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6360       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
6361       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
6362     }
6363   }
6364
6365   when = time(NULL);
6366 # ifdef VMSISH_TIME
6367 # ifdef RTL_USES_UTC
6368   if (VMSISH_TIME) when = _toloc(when);
6369 # else
6370   if (!VMSISH_TIME) when = _toutc(when);
6371 # endif
6372 # endif
6373   if (timep != NULL) *timep = when;
6374   return when;
6375
6376 }  /* end of my_time() */
6377 /*}}}*/
6378
6379
6380 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6381 struct tm *
6382 Perl_my_gmtime(pTHX_ const time_t *timep)
6383 {
6384   char *p;
6385   time_t when;
6386   struct tm *rsltmp;
6387
6388   if (timep == NULL) {
6389     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6390     return NULL;
6391   }
6392   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
6393
6394   when = *timep;
6395 # ifdef VMSISH_TIME
6396   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6397 #  endif
6398 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
6399   return gmtime(&when);
6400 # else
6401   /* CRTL localtime() wants local time as input, so does no tz correction */
6402   rsltmp = localtime(&when);
6403   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
6404   return rsltmp;
6405 #endif
6406 }  /* end of my_gmtime() */
6407 /*}}}*/
6408
6409
6410 /*{{{struct tm *my_localtime(const time_t *timep)*/
6411 struct tm *
6412 Perl_my_localtime(pTHX_ const time_t *timep)
6413 {
6414   time_t when, whenutc;
6415   struct tm *rsltmp;
6416   int dst, offset;
6417
6418   if (timep == NULL) {
6419     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6420     return NULL;
6421   }
6422   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
6423   if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6424
6425   when = *timep;
6426 # ifdef RTL_USES_UTC
6427 # ifdef VMSISH_TIME
6428   if (VMSISH_TIME) when = _toutc(when);
6429 # endif
6430   /* CRTL localtime() wants UTC as input, does tz correction itself */
6431   return localtime(&when);
6432
6433 # else /* !RTL_USES_UTC */
6434   whenutc = when;
6435 # ifdef VMSISH_TIME
6436   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
6437   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
6438 # endif
6439   dst = -1;
6440 #ifndef RTL_USES_UTC
6441   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
6442       when = whenutc - offset;                   /* pseudolocal time*/
6443   }
6444 # endif
6445   /* CRTL localtime() wants local time as input, so does no tz correction */
6446   rsltmp = localtime(&when);
6447   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6448   return rsltmp;
6449 # endif
6450
6451 } /*  end of my_localtime() */
6452 /*}}}*/
6453
6454 /* Reset definitions for later calls */
6455 #define gmtime(t)    my_gmtime(t)
6456 #define localtime(t) my_localtime(t)
6457 #define time(t)      my_time(t)
6458
6459
6460 /* my_utime - update modification time of a file
6461  * calling sequence is identical to POSIX utime(), but under
6462  * VMS only the modification time is changed; ODS-2 does not
6463  * maintain access times.  Restrictions differ from the POSIX
6464  * definition in that the time can be changed as long as the
6465  * caller has permission to execute the necessary IO$_MODIFY $QIO;
6466  * no separate checks are made to insure that the caller is the
6467  * owner of the file or has special privs enabled.
6468  * Code here is based on Joe Meadows' FILE utility.
6469  */
6470
6471 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6472  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
6473  * in 100 ns intervals.
6474  */
6475 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6476
6477 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
6478 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
6479 {
6480   register int i;
6481   long int bintime[2], len = 2, lowbit, unixtime,
6482            secscale = 10000000; /* seconds --> 100 ns intervals */
6483   unsigned long int chan, iosb[2], retsts;
6484   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6485   struct FAB myfab = cc$rms_fab;
6486   struct NAM mynam = cc$rms_nam;
6487 #if defined (__DECC) && defined (__VAX)
6488   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6489    * at least through VMS V6.1, which causes a type-conversion warning.
6490    */
6491 #  pragma message save
6492 #  pragma message disable cvtdiftypes
6493 #endif
6494   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6495   struct fibdef myfib;
6496 #if defined (__DECC) && defined (__VAX)
6497   /* This should be right after the declaration of myatr, but due
6498    * to a bug in VAX DEC C, this takes effect a statement early.
6499    */
6500 #  pragma message restore
6501 #endif
6502   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6503                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6504                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6505
6506   if (file == NULL || *file == '\0') {
6507     set_errno(ENOENT);
6508     set_vaxc_errno(LIB$_INVARG);
6509     return -1;
6510   }
6511   if (do_tovmsspec((char *)file,vmsspec,0) == NULL) return -1;
6512
6513   if (utimes != NULL) {
6514     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
6515      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6516      * Since time_t is unsigned long int, and lib$emul takes a signed long int
6517      * as input, we force the sign bit to be clear by shifting unixtime right
6518      * one bit, then multiplying by an extra factor of 2 in lib$emul().
6519      */
6520     lowbit = (utimes->modtime & 1) ? secscale : 0;
6521     unixtime = (long int) utimes->modtime;
6522 #   ifdef VMSISH_TIME
6523     /* If input was UTC; convert to local for sys svc */
6524     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6525 #   endif
6526     unixtime >>= 1;  secscale <<= 1;
6527     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6528     if (!(retsts & 1)) {
6529       set_errno(EVMSERR);
6530       set_vaxc_errno(retsts);
6531       return -1;
6532     }
6533     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6534     if (!(retsts & 1)) {
6535       set_errno(EVMSERR);
6536       set_vaxc_errno(retsts);
6537       return -1;
6538     }
6539   }
6540   else {
6541     /* Just get the current time in VMS format directly */
6542     retsts = sys$gettim(bintime);
6543     if (!(retsts & 1)) {
6544       set_errno(EVMSERR);
6545       set_vaxc_errno(retsts);
6546       return -1;
6547     }
6548   }
6549
6550   myfab.fab$l_fna = vmsspec;
6551   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6552   myfab.fab$l_nam = &mynam;
6553   mynam.nam$l_esa = esa;
6554   mynam.nam$b_ess = (unsigned char) sizeof esa;
6555   mynam.nam$l_rsa = rsa;
6556   mynam.nam$b_rss = (unsigned char) sizeof rsa;
6557
6558   /* Look for the file to be affected, letting RMS parse the file
6559    * specification for us as well.  I have set errno using only
6560    * values documented in the utime() man page for VMS POSIX.
6561    */
6562   retsts = sys$parse(&myfab,0,0);
6563   if (!(retsts & 1)) {
6564     set_vaxc_errno(retsts);
6565     if      (retsts == RMS$_PRV) set_errno(EACCES);
6566     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6567     else                         set_errno(EVMSERR);
6568     return -1;
6569   }
6570   retsts = sys$search(&myfab,0,0);
6571   if (!(retsts & 1)) {
6572     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6573     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6574     set_vaxc_errno(retsts);
6575     if      (retsts == RMS$_PRV) set_errno(EACCES);
6576     else if (retsts == RMS$_FNF) set_errno(ENOENT);
6577     else                         set_errno(EVMSERR);
6578     return -1;
6579   }
6580
6581   devdsc.dsc$w_length = mynam.nam$b_dev;
6582   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6583
6584   retsts = sys$assign(&devdsc,&chan,0,0);
6585   if (!(retsts & 1)) {
6586     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6587     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6588     set_vaxc_errno(retsts);
6589     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
6590     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
6591     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
6592     else                               set_errno(EVMSERR);
6593     return -1;
6594   }
6595
6596   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6597   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6598
6599   memset((void *) &myfib, 0, sizeof myfib);
6600 #if defined(__DECC) || defined(__DECCXX)
6601   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6602   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6603   /* This prevents the revision time of the file being reset to the current
6604    * time as a result of our IO$_MODIFY $QIO. */
6605   myfib.fib$l_acctl = FIB$M_NORECORD;
6606 #else
6607   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6608   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6609   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6610 #endif
6611   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6612   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6613   myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6614   _ckvmssts(sys$dassgn(chan));
6615   if (retsts & 1) retsts = iosb[0];
6616   if (!(retsts & 1)) {
6617     set_vaxc_errno(retsts);
6618     if (retsts == SS$_NOPRIV) set_errno(EACCES);
6619     else                      set_errno(EVMSERR);
6620     return -1;
6621   }
6622
6623   return 0;
6624 }  /* end of my_utime() */
6625 /*}}}*/
6626
6627 /*
6628  * flex_stat, flex_fstat
6629  * basic stat, but gets it right when asked to stat
6630  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6631  */
6632
6633 /* encode_dev packs a VMS device name string into an integer to allow
6634  * simple comparisons. This can be used, for example, to check whether two
6635  * files are located on the same device, by comparing their encoded device
6636  * names. Even a string comparison would not do, because stat() reuses the
6637  * device name buffer for each call; so without encode_dev, it would be
6638  * necessary to save the buffer and use strcmp (this would mean a number of
6639  * changes to the standard Perl code, to say nothing of what a Perl script
6640  * would have to do.
6641  *
6642  * The device lock id, if it exists, should be unique (unless perhaps compared
6643  * with lock ids transferred from other nodes). We have a lock id if the disk is
6644  * mounted cluster-wide, which is when we tend to get long (host-qualified)
6645  * device names. Thus we use the lock id in preference, and only if that isn't
6646  * available, do we try to pack the device name into an integer (flagged by
6647  * the sign bit (LOCKID_MASK) being set).
6648  *
6649  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6650  * name and its encoded form, but it seems very unlikely that we will find
6651  * two files on different disks that share the same encoded device names,
6652  * and even more remote that they will share the same file id (if the test
6653  * is to check for the same file).
6654  *
6655  * A better method might be to use sys$device_scan on the first call, and to
6656  * search for the device, returning an index into the cached array.
6657  * The number returned would be more intelligable.
6658  * This is probably not worth it, and anyway would take quite a bit longer
6659  * on the first call.
6660  */
6661 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
6662 static mydev_t encode_dev (pTHX_ const char *dev)
6663 {
6664   int i;
6665   unsigned long int f;
6666   mydev_t enc;
6667   char c;
6668   const char *q;
6669
6670   if (!dev || !dev[0]) return 0;
6671
6672 #if LOCKID_MASK
6673   {
6674     struct dsc$descriptor_s dev_desc;
6675     unsigned long int status, lockid, item = DVI$_LOCKID;
6676
6677     /* For cluster-mounted disks, the disk lock identifier is unique, so we
6678        can try that first. */
6679     dev_desc.dsc$w_length =  strlen (dev);
6680     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
6681     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
6682     dev_desc.dsc$a_pointer = (char *) dev;
6683     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6684     if (lockid) return (lockid & ~LOCKID_MASK);
6685   }
6686 #endif
6687
6688   /* Otherwise we try to encode the device name */
6689   enc = 0;
6690   f = 1;
6691   i = 0;
6692   for (q = dev + strlen(dev); q--; q >= dev) {
6693     if (isdigit (*q))
6694       c= (*q) - '0';
6695     else if (isalpha (toupper (*q)))
6696       c= toupper (*q) - 'A' + (char)10;
6697     else
6698       continue; /* Skip '$'s */
6699     i++;
6700     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
6701     if (i>1) f *= 36;
6702     enc += f * (unsigned long int) c;
6703   }
6704   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
6705
6706 }  /* end of encode_dev() */
6707
6708 static char namecache[NAM$C_MAXRSS+1];
6709
6710 static int
6711 is_null_device(name)
6712     const char *name;
6713 {
6714     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6715        The underscore prefix, controller letter, and unit number are
6716        independently optional; for our purposes, the colon punctuation
6717        is not.  The colon can be trailed by optional directory and/or
6718        filename, but two consecutive colons indicates a nodename rather
6719        than a device.  [pr]  */
6720   if (*name == '_') ++name;
6721   if (tolower(*name++) != 'n') return 0;
6722   if (tolower(*name++) != 'l') return 0;
6723   if (tolower(*name) == 'a') ++name;
6724   if (*name == '0') ++name;
6725   return (*name++ == ':') && (*name != ':');
6726 }
6727
6728 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
6729 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6730  * subset of the applicable information.
6731  */
6732 bool
6733 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, const Stat_t *statbufp)
6734 {
6735   char fname_phdev[NAM$C_MAXRSS+1];
6736   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6737   else {
6738     char fname[NAM$C_MAXRSS+1];
6739     unsigned long int retsts;
6740     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6741                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6742
6743     /* If the struct mystat is stale, we're OOL; stat() overwrites the
6744        device name on successive calls */
6745     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6746     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6747     namdsc.dsc$a_pointer = fname;
6748     namdsc.dsc$w_length = sizeof fname - 1;
6749
6750     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6751                              &namdsc,&namdsc.dsc$w_length,0,0);
6752     if (retsts & 1) {
6753       fname[namdsc.dsc$w_length] = '\0';
6754 /*
6755  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6756  * but if someone has redefined that logical, Perl gets very lost.  Since
6757  * we have the physical device name from the stat buffer, just paste it on.
6758  */
6759       strcpy( fname_phdev, statbufp->st_devnam );
6760       strcat( fname_phdev, strrchr(fname, ':') );
6761
6762       return cando_by_name(bit,effective,fname_phdev);
6763     }
6764     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6765       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6766       return FALSE;
6767     }
6768     _ckvmssts(retsts);
6769     return FALSE;  /* Should never get to here */
6770   }
6771 }  /* end of cando() */
6772 /*}}}*/
6773
6774
6775 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6776 I32
6777 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6778 {
6779   static char usrname[L_cuserid];
6780   static struct dsc$descriptor_s usrdsc =
6781          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6782   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6783   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6784   unsigned short int retlen, trnlnm_iter_count;
6785   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6786   union prvdef curprv;
6787   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6788          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6789   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6790          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6791          {0,0,0,0}};
6792   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6793          {0,0,0,0}};
6794   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6795
6796   if (!fname || !*fname) return FALSE;
6797   /* Make sure we expand logical names, since sys$check_access doesn't */
6798   if (!strpbrk(fname,"/]>:")) {
6799     strcpy(fileified,fname);
6800     trnlnm_iter_count = 0;
6801     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
6802         trnlnm_iter_count++;
6803         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6804     }
6805     fname = fileified;
6806   }
6807   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6808   retlen = namdsc.dsc$w_length = strlen(vmsname);
6809   namdsc.dsc$a_pointer = vmsname;
6810   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6811       vmsname[retlen-1] == ':') {
6812     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6813     namdsc.dsc$w_length = strlen(fileified);
6814     namdsc.dsc$a_pointer = fileified;
6815   }
6816
6817   switch (bit) {
6818     case S_IXUSR: case S_IXGRP: case S_IXOTH:
6819       access = ARM$M_EXECUTE; break;
6820     case S_IRUSR: case S_IRGRP: case S_IROTH:
6821       access = ARM$M_READ; break;
6822     case S_IWUSR: case S_IWGRP: case S_IWOTH:
6823       access = ARM$M_WRITE; break;
6824     case S_IDUSR: case S_IDGRP: case S_IDOTH:
6825       access = ARM$M_DELETE; break;
6826     default:
6827       return FALSE;
6828   }
6829
6830   /* Before we call $check_access, create a user profile with the current
6831    * process privs since otherwise it just uses the default privs from the
6832    * UAF and might give false positives or negatives.  This only works on
6833    * VMS versions v6.0 and later since that's when sys$create_user_profile
6834    * became available.
6835    */
6836
6837   /* get current process privs and username */
6838   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6839   _ckvmssts(iosb[0]);
6840
6841 #if defined(__VMS_VER) && __VMS_VER >= 60000000
6842
6843   /* find out the space required for the profile */
6844   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6845                                     &usrprodsc.dsc$w_length,0));
6846
6847   /* allocate space for the profile and get it filled in */
6848   Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6849   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6850                                     &usrprodsc.dsc$w_length,0));
6851
6852   /* use the profile to check access to the file; free profile & analyze results */
6853   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6854   Safefree(usrprodsc.dsc$a_pointer);
6855   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6856
6857 #else
6858
6859   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6860
6861 #endif
6862
6863   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
6864       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6865       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6866     set_vaxc_errno(retsts);
6867     if (retsts == SS$_NOPRIV) set_errno(EACCES);
6868     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6869     else set_errno(ENOENT);
6870     return FALSE;
6871   }
6872   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6873     return TRUE;
6874   }
6875   _ckvmssts(retsts);
6876
6877   return FALSE;  /* Should never get here */
6878
6879 }  /* end of cando_by_name() */
6880 /*}}}*/
6881
6882
6883 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6884 int
6885 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6886 {
6887   if (!fstat(fd,(stat_t *) statbufp)) {
6888     if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6889     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6890 #   ifdef RTL_USES_UTC
6891 #   ifdef VMSISH_TIME
6892     if (VMSISH_TIME) {
6893       statbufp->st_mtime = _toloc(statbufp->st_mtime);
6894       statbufp->st_atime = _toloc(statbufp->st_atime);
6895       statbufp->st_ctime = _toloc(statbufp->st_ctime);
6896     }
6897 #   endif
6898 #   else
6899 #   ifdef VMSISH_TIME
6900     if (!VMSISH_TIME) { /* Return UTC instead of local time */
6901 #   else
6902     if (1) {
6903 #   endif
6904       statbufp->st_mtime = _toutc(statbufp->st_mtime);
6905       statbufp->st_atime = _toutc(statbufp->st_atime);
6906       statbufp->st_ctime = _toutc(statbufp->st_ctime);
6907     }
6908 #endif
6909     return 0;
6910   }
6911   return -1;
6912
6913 }  /* end of flex_fstat() */
6914 /*}}}*/
6915
6916 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6917 int
6918 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6919 {
6920     char fileified[NAM$C_MAXRSS+1];
6921     char temp_fspec[NAM$C_MAXRSS+300];
6922     int retval = -1;
6923     int saved_errno, saved_vaxc_errno;
6924
6925     if (!fspec) return retval;
6926     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6927     strcpy(temp_fspec, fspec);
6928     if (statbufp == (Stat_t *) &PL_statcache)
6929       do_tovmsspec(temp_fspec,namecache,0);
6930     if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6931       memset(statbufp,0,sizeof *statbufp);
6932       statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6933       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6934       statbufp->st_uid = 0x00010001;
6935       statbufp->st_gid = 0x0001;
6936       time((time_t *)&statbufp->st_mtime);
6937       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6938       return 0;
6939     }
6940
6941     /* Try for a directory name first.  If fspec contains a filename without
6942      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6943      * and sea:[wine.dark]water. exist, we prefer the directory here.
6944      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6945      * not sea:[wine.dark]., if the latter exists.  If the intended target is
6946      * the file with null type, specify this by calling flex_stat() with
6947      * a '.' at the end of fspec.
6948      */
6949     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6950       retval = stat(fileified,(stat_t *) statbufp);
6951       if (!retval && statbufp == (Stat_t *) &PL_statcache)
6952         strcpy(namecache,fileified);
6953     }
6954     if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6955     if (!retval) {
6956       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6957 #     ifdef RTL_USES_UTC
6958 #     ifdef VMSISH_TIME
6959       if (VMSISH_TIME) {
6960         statbufp->st_mtime = _toloc(statbufp->st_mtime);
6961         statbufp->st_atime = _toloc(statbufp->st_atime);
6962         statbufp->st_ctime = _toloc(statbufp->st_ctime);
6963       }
6964 #     endif
6965 #     else
6966 #     ifdef VMSISH_TIME
6967       if (!VMSISH_TIME) { /* Return UTC instead of local time */
6968 #     else
6969       if (1) {
6970 #     endif
6971         statbufp->st_mtime = _toutc(statbufp->st_mtime);
6972         statbufp->st_atime = _toutc(statbufp->st_atime);
6973         statbufp->st_ctime = _toutc(statbufp->st_ctime);
6974       }
6975 #     endif
6976     }
6977     /* If we were successful, leave errno where we found it */
6978     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6979     return retval;
6980
6981 }  /* end of flex_stat() */
6982 /*}}}*/
6983
6984
6985 /*{{{char *my_getlogin()*/
6986 /* VMS cuserid == Unix getlogin, except calling sequence */
6987 char *
6988 my_getlogin()
6989 {
6990     static char user[L_cuserid];
6991     return cuserid(user);
6992 }
6993 /*}}}*/
6994
6995
6996 /*  rmscopy - copy a file using VMS RMS routines
6997  *
6998  *  Copies contents and attributes of spec_in to spec_out, except owner
6999  *  and protection information.  Name and type of spec_in are used as
7000  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
7001  *  should try to propagate timestamps from the input file to the output file.
7002  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
7003  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
7004  *  propagated to the output file at creation iff the output file specification
7005  *  did not contain an explicit name or type, and the revision date is always
7006  *  updated at the end of the copy operation.  If it is greater than 0, then
7007  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
7008  *  other than the revision date should be propagated, and bit 1 indicates
7009  *  that the revision date should be propagated.
7010  *
7011  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
7012  *
7013  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
7014  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
7015  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
7016  * as part of the Perl standard distribution under the terms of the
7017  * GNU General Public License or the Perl Artistic License.  Copies
7018  * of each may be found in the Perl standard distribution.
7019  */
7020 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
7021 int
7022 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
7023 {
7024     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
7025          rsa[NAM$C_MAXRSS], ubf[32256];
7026     unsigned long int i, sts, sts2;
7027     struct FAB fab_in, fab_out;
7028     struct RAB rab_in, rab_out;
7029     struct NAM nam;
7030     struct XABDAT xabdat;
7031     struct XABFHC xabfhc;
7032     struct XABRDT xabrdt;
7033     struct XABSUM xabsum;
7034
7035     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
7036         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
7037       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7038       return 0;
7039     }
7040
7041     fab_in = cc$rms_fab;
7042     fab_in.fab$l_fna = vmsin;
7043     fab_in.fab$b_fns = strlen(vmsin);
7044     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
7045     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
7046     fab_in.fab$l_fop = FAB$M_SQO;
7047     fab_in.fab$l_nam =  &nam;
7048     fab_in.fab$l_xab = (void *) &xabdat;
7049
7050     nam = cc$rms_nam;
7051     nam.nam$l_rsa = rsa;
7052     nam.nam$b_rss = sizeof(rsa);
7053     nam.nam$l_esa = esa;
7054     nam.nam$b_ess = sizeof (esa);
7055     nam.nam$b_esl = nam.nam$b_rsl = 0;
7056
7057     xabdat = cc$rms_xabdat;        /* To get creation date */
7058     xabdat.xab$l_nxt = (void *) &xabfhc;
7059
7060     xabfhc = cc$rms_xabfhc;        /* To get record length */
7061     xabfhc.xab$l_nxt = (void *) &xabsum;
7062
7063     xabsum = cc$rms_xabsum;        /* To get key and area information */
7064
7065     if (!((sts = sys$open(&fab_in)) & 1)) {
7066       set_vaxc_errno(sts);
7067       switch (sts) {
7068         case RMS$_FNF: case RMS$_DNF:
7069           set_errno(ENOENT); break;
7070         case RMS$_DIR:
7071           set_errno(ENOTDIR); break;
7072         case RMS$_DEV:
7073           set_errno(ENODEV); break;
7074         case RMS$_SYN:
7075           set_errno(EINVAL); break;
7076         case RMS$_PRV:
7077           set_errno(EACCES); break;
7078         default:
7079           set_errno(EVMSERR);
7080       }
7081       return 0;
7082     }
7083
7084     fab_out = fab_in;
7085     fab_out.fab$w_ifi = 0;
7086     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
7087     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
7088     fab_out.fab$l_fop = FAB$M_SQO;
7089     fab_out.fab$l_fna = vmsout;
7090     fab_out.fab$b_fns = strlen(vmsout);
7091     fab_out.fab$l_dna = nam.nam$l_name;
7092     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
7093
7094     if (preserve_dates == 0) {  /* Act like DCL COPY */
7095       nam.nam$b_nop = NAM$M_SYNCHK;
7096       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
7097       if (!((sts = sys$parse(&fab_out)) & 1)) {
7098         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
7099         set_vaxc_errno(sts);
7100         return 0;
7101       }
7102       fab_out.fab$l_xab = (void *) &xabdat;
7103       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
7104     }
7105     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
7106     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
7107       preserve_dates =0;      /* bitmask from this point forward   */
7108
7109     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
7110     if (!((sts = sys$create(&fab_out)) & 1)) {
7111       set_vaxc_errno(sts);
7112       switch (sts) {
7113         case RMS$_DNF:
7114           set_errno(ENOENT); break;
7115         case RMS$_DIR:
7116           set_errno(ENOTDIR); break;
7117         case RMS$_DEV:
7118           set_errno(ENODEV); break;
7119         case RMS$_SYN:
7120           set_errno(EINVAL); break;
7121         case RMS$_PRV:
7122           set_errno(EACCES); break;
7123         default:
7124           set_errno(EVMSERR);
7125       }
7126       return 0;
7127     }
7128     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
7129     if (preserve_dates & 2) {
7130       /* sys$close() will process xabrdt, not xabdat */
7131       xabrdt = cc$rms_xabrdt;
7132 #ifndef __GNUC__
7133       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
7134 #else
7135       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
7136        * is unsigned long[2], while DECC & VAXC use a struct */
7137       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
7138 #endif
7139       fab_out.fab$l_xab = (void *) &xabrdt;
7140     }
7141
7142     rab_in = cc$rms_rab;
7143     rab_in.rab$l_fab = &fab_in;
7144     rab_in.rab$l_rop = RAB$M_BIO;
7145     rab_in.rab$l_ubf = ubf;
7146     rab_in.rab$w_usz = sizeof ubf;
7147     if (!((sts = sys$connect(&rab_in)) & 1)) {
7148       sys$close(&fab_in); sys$close(&fab_out);
7149       set_errno(EVMSERR); set_vaxc_errno(sts);
7150       return 0;
7151     }
7152
7153     rab_out = cc$rms_rab;
7154     rab_out.rab$l_fab = &fab_out;
7155     rab_out.rab$l_rbf = ubf;
7156     if (!((sts = sys$connect(&rab_out)) & 1)) {
7157       sys$close(&fab_in); sys$close(&fab_out);
7158       set_errno(EVMSERR); set_vaxc_errno(sts);
7159       return 0;
7160     }
7161
7162     while ((sts = sys$read(&rab_in))) {  /* always true  */
7163       if (sts == RMS$_EOF) break;
7164       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
7165       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
7166         sys$close(&fab_in); sys$close(&fab_out);
7167         set_errno(EVMSERR); set_vaxc_errno(sts);
7168         return 0;
7169       }
7170     }
7171
7172     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
7173     sys$close(&fab_in);  sys$close(&fab_out);
7174     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
7175     if (!(sts & 1)) {
7176       set_errno(EVMSERR); set_vaxc_errno(sts);
7177       return 0;
7178     }
7179
7180     return 1;
7181
7182 }  /* end of rmscopy() */
7183 /*}}}*/
7184
7185
7186 /***  The following glue provides 'hooks' to make some of the routines
7187  * from this file available from Perl.  These routines are sufficiently
7188  * basic, and are required sufficiently early in the build process,
7189  * that's it's nice to have them available to miniperl as well as the
7190  * full Perl, so they're set up here instead of in an extension.  The
7191  * Perl code which handles importation of these names into a given
7192  * package lives in [.VMS]Filespec.pm in @INC.
7193  */
7194
7195 void
7196 rmsexpand_fromperl(pTHX_ CV *cv)
7197 {
7198   dXSARGS;
7199   char *fspec, *defspec = NULL, *rslt;
7200   STRLEN n_a;
7201
7202   if (!items || items > 2)
7203     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
7204   fspec = SvPV(ST(0),n_a);
7205   if (!fspec || !*fspec) XSRETURN_UNDEF;
7206   if (items == 2) defspec = SvPV(ST(1),n_a);
7207
7208   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
7209   ST(0) = sv_newmortal();
7210   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
7211   XSRETURN(1);
7212 }
7213
7214 void
7215 vmsify_fromperl(pTHX_ CV *cv)
7216 {
7217   dXSARGS;
7218   char *vmsified;
7219   STRLEN n_a;
7220
7221   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
7222   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
7223   ST(0) = sv_newmortal();
7224   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7225   XSRETURN(1);
7226 }
7227
7228 void
7229 unixify_fromperl(pTHX_ CV *cv)
7230 {
7231   dXSARGS;
7232   char *unixified;
7233   STRLEN n_a;
7234
7235   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7236   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7237   ST(0) = sv_newmortal();
7238   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7239   XSRETURN(1);
7240 }
7241
7242 void
7243 fileify_fromperl(pTHX_ CV *cv)
7244 {
7245   dXSARGS;
7246   char *fileified;
7247   STRLEN n_a;
7248
7249   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7250   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7251   ST(0) = sv_newmortal();
7252   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7253   XSRETURN(1);
7254 }
7255
7256 void
7257 pathify_fromperl(pTHX_ CV *cv)
7258 {
7259   dXSARGS;
7260   char *pathified;
7261   STRLEN n_a;
7262
7263   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7264   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7265   ST(0) = sv_newmortal();
7266   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7267   XSRETURN(1);
7268 }
7269
7270 void
7271 vmspath_fromperl(pTHX_ CV *cv)
7272 {
7273   dXSARGS;
7274   char *vmspath;
7275   STRLEN n_a;
7276
7277   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7278   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7279   ST(0) = sv_newmortal();
7280   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7281   XSRETURN(1);
7282 }
7283
7284 void
7285 unixpath_fromperl(pTHX_ CV *cv)
7286 {
7287   dXSARGS;
7288   char *unixpath;
7289   STRLEN n_a;
7290
7291   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7292   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7293   ST(0) = sv_newmortal();
7294   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7295   XSRETURN(1);
7296 }
7297
7298 void
7299 candelete_fromperl(pTHX_ CV *cv)
7300 {
7301   dXSARGS;
7302   char fspec[NAM$C_MAXRSS+1], *fsp;
7303   SV *mysv;
7304   IO *io;
7305   STRLEN n_a;
7306
7307   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7308
7309   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7310   if (SvTYPE(mysv) == SVt_PVGV) {
7311     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7312       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7313       ST(0) = &PL_sv_no;
7314       XSRETURN(1);
7315     }
7316     fsp = fspec;
7317   }
7318   else {
7319     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7320       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7321       ST(0) = &PL_sv_no;
7322       XSRETURN(1);
7323     }
7324   }
7325
7326   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7327   XSRETURN(1);
7328 }
7329
7330 void
7331 rmscopy_fromperl(pTHX_ CV *cv)
7332 {
7333   dXSARGS;
7334   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7335   int date_flag;
7336   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7337                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7338   unsigned long int sts;
7339   SV *mysv;
7340   IO *io;
7341   STRLEN n_a;
7342
7343   if (items < 2 || items > 3)
7344     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7345
7346   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7347   if (SvTYPE(mysv) == SVt_PVGV) {
7348     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7349       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7350       ST(0) = &PL_sv_no;
7351       XSRETURN(1);
7352     }
7353     inp = inspec;
7354   }
7355   else {
7356     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7357       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7358       ST(0) = &PL_sv_no;
7359       XSRETURN(1);
7360     }
7361   }
7362   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7363   if (SvTYPE(mysv) == SVt_PVGV) {
7364     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7365       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7366       ST(0) = &PL_sv_no;
7367       XSRETURN(1);
7368     }
7369     outp = outspec;
7370   }
7371   else {
7372     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7373       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7374       ST(0) = &PL_sv_no;
7375       XSRETURN(1);
7376     }
7377   }
7378   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7379
7380   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7381   XSRETURN(1);
7382 }
7383
7384
7385 void
7386 mod2fname(pTHX_ CV *cv)
7387 {
7388   dXSARGS;
7389   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7390        workbuff[NAM$C_MAXRSS*1 + 1];
7391   int total_namelen = 3, counter, num_entries;
7392   /* ODS-5 ups this, but we want to be consistent, so... */
7393   int max_name_len = 39;
7394   AV *in_array = (AV *)SvRV(ST(0));
7395
7396   num_entries = av_len(in_array);
7397
7398   /* All the names start with PL_. */
7399   strcpy(ultimate_name, "PL_");
7400
7401   /* Clean up our working buffer */
7402   Zero(work_name, sizeof(work_name), char);
7403
7404   /* Run through the entries and build up a working name */
7405   for(counter = 0; counter <= num_entries; counter++) {
7406     /* If it's not the first name then tack on a __ */
7407     if (counter) {
7408       strcat(work_name, "__");
7409     }
7410     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7411                            PL_na));
7412   }
7413
7414   /* Check to see if we actually have to bother...*/
7415   if (strlen(work_name) + 3 <= max_name_len) {
7416     strcat(ultimate_name, work_name);
7417   } else {
7418     /* It's too darned big, so we need to go strip. We use the same */
7419     /* algorithm as xsubpp does. First, strip out doubled __ */
7420     char *source, *dest, last;
7421     dest = workbuff;
7422     last = 0;
7423     for (source = work_name; *source; source++) {
7424       if (last == *source && last == '_') {
7425         continue;
7426       }
7427       *dest++ = *source;
7428       last = *source;
7429     }
7430     /* Go put it back */
7431     strcpy(work_name, workbuff);
7432     /* Is it still too big? */
7433     if (strlen(work_name) + 3 > max_name_len) {
7434       /* Strip duplicate letters */
7435       last = 0;
7436       dest = workbuff;
7437       for (source = work_name; *source; source++) {
7438         if (last == toupper(*source)) {
7439         continue;
7440         }
7441         *dest++ = *source;
7442         last = toupper(*source);
7443       }
7444       strcpy(work_name, workbuff);
7445     }
7446
7447     /* Is it *still* too big? */
7448     if (strlen(work_name) + 3 > max_name_len) {
7449       /* Too bad, we truncate */
7450       work_name[max_name_len - 2] = 0;
7451     }
7452     strcat(ultimate_name, work_name);
7453   }
7454
7455   /* Okay, return it */
7456   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7457   XSRETURN(1);
7458 }
7459
7460 void
7461 hushexit_fromperl(pTHX_ CV *cv)
7462 {
7463     dXSARGS;
7464
7465     if (items > 0) {
7466         VMSISH_HUSHED = SvTRUE(ST(0));
7467     }
7468     ST(0) = boolSV(VMSISH_HUSHED);
7469     XSRETURN(1);
7470 }
7471
7472 void
7473 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7474                           struct interp_intern *dst)
7475 {
7476     memcpy(dst,src,sizeof(struct interp_intern));
7477 }
7478
7479 void
7480 Perl_sys_intern_clear(pTHX)
7481 {
7482 }
7483
7484 void
7485 Perl_sys_intern_init(pTHX)
7486 {
7487     unsigned int ix = RAND_MAX;
7488     double x;
7489
7490     VMSISH_HUSHED = 0;
7491
7492     x = (float)ix;
7493     MY_INV_RAND_MAX = 1./x;
7494 }
7495
7496 void
7497 init_os_extras()
7498 {
7499   dTHX;
7500   char* file = __FILE__;
7501   char temp_buff[512];
7502   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7503     no_translate_barewords = TRUE;
7504   } else {
7505     no_translate_barewords = FALSE;
7506   }
7507
7508   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7509   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7510   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7511   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7512   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7513   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7514   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7515   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7516   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7517   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7518   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7519
7520   store_pipelocs(aTHX);         /* will redo any earlier attempts */
7521
7522   return;
7523 }
7524
7525 /*  End of vms.c */