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