vms/vms.c

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