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