vms/vms.c

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