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