vms/vms.c

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