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