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 char *had_version;
4256 char *had_device;
4257 int had_directory;
4258 char *devdir,*cp;
4259 char vmsspec[NAM$C_MAXRSS+1];
4260 $DESCRIPTOR(filespec, "");
4261 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4262 $DESCRIPTOR(resultspec, "");
4263 unsigned long int zero = 0, sts;
4264
4265     for (cp = item; *cp; cp++) {
4266         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4267         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4268     }
4269     if (!*cp || isspace(*cp))
4270         {
4271         add_item(head, tail, item, count);
4272         return;
4273         }
4274     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4275     resultspec.dsc$b_class = DSC$K_CLASS_D;
4276     resultspec.dsc$a_pointer = NULL;
4277     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4278       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4279     if (!isunix || !filespec.dsc$a_pointer)
4280       filespec.dsc$a_pointer = item;
4281     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4282     /*
4283      * Only return version specs, if the caller specified a version
4284      */
4285     had_version = strchr(item, ';');
4286     /*
4287      * Only return device and directory specs, if the caller specifed either.
4288      */
4289     had_device = strchr(item, ':');
4290     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4291
4292     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4293                                   &defaultspec, 0, 0, &zero))))
4294         {
4295         char *string;
4296         char *c;
4297
4298         New(1305,string,resultspec.dsc$w_length+1,char);
4299         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4300         string[resultspec.dsc$w_length] = '\0';
4301         if (NULL == had_version)
4302             *((char *)strrchr(string, ';')) = '\0';
4303         if ((!had_directory) && (had_device == NULL))
4304             {
4305             if (NULL == (devdir = strrchr(string, ']')))
4306                 devdir = strrchr(string, '>');
4307             strcpy(string, devdir + 1);
4308             }
4309         /*
4310          * Be consistent with what the C RTL has already done to the rest of
4311          * the argv items and lowercase all of these names.
4312          */
4313         for (c = string; *c; ++c)
4314             if (isupper(*c))
4315                 *c = tolower(*c);
4316         if (isunix) trim_unixpath(string,item,1);
4317         add_item(head, tail, string, count);
4318         ++expcount;
4319         }
4320     if (sts != RMS$_NMF)
4321         {
4322         set_vaxc_errno(sts);
4323         switch (sts)
4324             {
4325             case RMS$_FNF: case RMS$_DNF:
4326                 set_errno(ENOENT); break;
4327             case RMS$_DIR:
4328                 set_errno(ENOTDIR); break;
4329             case RMS$_DEV:
4330                 set_errno(ENODEV); break;
4331             case RMS$_FNM: case RMS$_SYN:
4332                 set_errno(EINVAL); break;
4333             case RMS$_PRV:
4334                 set_errno(EACCES); break;
4335             default:
4336                 _ckvmssts_noperl(sts);
4337             }
4338         }
4339     if (expcount == 0)
4340         add_item(head, tail, item, count);
4341     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4342     _ckvmssts_noperl(lib$find_file_end(&context));
4343 }
4344
4345 static int child_st[2];/* Event Flag set when child process completes   */
4346
4347 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
4348
4349 static unsigned long int exit_handler(int *status)
4350 {
4351 short iosb[4];
4352
4353     if (0 == child_st[0])
4354         {
4355 #ifdef ARGPROC_DEBUG
4356         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4357 #endif
4358         fflush(stdout);     /* Have to flush pipe for binary data to    */
4359                             /* terminate properly -- <tp@mccall.com>    */
4360         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4361         sys$dassgn(child_chan);
4362         fclose(stdout);
4363         sys$synch(0, child_st);
4364         }
4365     return(1);
4366 }
4367
4368 static void sig_child(int chan)
4369 {
4370 #ifdef ARGPROC_DEBUG
4371     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4372 #endif
4373     if (child_st[0] == 0)
4374         child_st[0] = 1;
4375 }
4376
4377 static struct exit_control_block exit_block =
4378     {
4379     0,
4380     exit_handler,
4381     1,
4382     &exit_block.exit_status,
4383     0
4384     };
4385
4386 static void
4387 pipe_and_fork(pTHX_ char **cmargv)
4388 {
4389     PerlIO *fp;
4390     struct dsc$descriptor_s *vmscmd;
4391     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4392     int sts, j, l, ismcr, quote, tquote = 0;
4393
4394     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
4395     vms_execfree(vmscmd);
4396
4397     j = l = 0;
4398     p = subcmd;
4399     q = cmargv[0];
4400     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
4401               && toupper(*(q+2)) == 'R' && !*(q+3);
4402
4403     while (q && l < MAX_DCL_LINE_LENGTH) {
4404         if (!*q) {
4405             if (j > 0 && quote) {
4406                 *p++ = '"';
4407                 l++;
4408             }
4409             q = cmargv[++j];
4410             if (q) {
4411                 if (ismcr && j > 1) quote = 1;
4412                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
4413                 *p++ = ' ';
4414                 l++;
4415                 if (quote || tquote) {
4416                     *p++ = '"';
4417                     l++;
4418                 }
4419         }
4420         } else {
4421             if ((quote||tquote) && *q == '"') {
4422                 *p++ = '"';
4423                 l++;
4424         }
4425             *p++ = *q++;
4426             l++;
4427         }
4428     }
4429     *p = '\0';
4430
4431     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4432     if (fp == Nullfp) {
4433         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4434         }
4435 }
4436
4437 static int background_process(pTHX_ int argc, char **argv)
4438 {
4439 char command[2048] = "$";
4440 $DESCRIPTOR(value, "");
4441 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4442 static $DESCRIPTOR(null, "NLA0:");
4443 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4444 char pidstring[80];
4445 $DESCRIPTOR(pidstr, "");
4446 int pid;
4447 unsigned long int flags = 17, one = 1, retsts;
4448
4449     strcat(command, argv[0]);
4450     while (--argc)
4451         {
4452         strcat(command, " \"");
4453         strcat(command, *(++argv));
4454         strcat(command, "\"");
4455         }
4456     value.dsc$a_pointer = command;
4457     value.dsc$w_length = strlen(value.dsc$a_pointer);
4458     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4459     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4460     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4461         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4462     }
4463     else {
4464         _ckvmssts_noperl(retsts);
4465     }
4466 #ifdef ARGPROC_DEBUG
4467     PerlIO_printf(Perl_debug_log, "%s\n", command);
4468 #endif
4469     sprintf(pidstring, "%08X", pid);
4470     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4471     pidstr.dsc$a_pointer = pidstring;
4472     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4473     lib$set_symbol(&pidsymbol, &pidstr);
4474     return(SS$_NORMAL);
4475 }
4476 /*}}}*/
4477 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4478
4479
4480 /* OS-specific initialization at image activation (not thread startup) */
4481 /* Older VAXC header files lack these constants */
4482 #ifndef JPI$_RIGHTS_SIZE
4483 #  define JPI$_RIGHTS_SIZE 817
4484 #endif
4485 #ifndef KGB$M_SUBSYSTEM
4486 #  define KGB$M_SUBSYSTEM 0x8
4487 #endif
4488
4489 /*{{{void vms_image_init(int *, char ***)*/
4490 void
4491 vms_image_init(int *argcp, char ***argvp)
4492 {
4493   char eqv[LNM$C_NAMLENGTH+1] = "";
4494   unsigned int len, tabct = 8, tabidx = 0;
4495   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4496   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4497   unsigned short int dummy, rlen;
4498   struct dsc$descriptor_s **tabvec;
4499 #if defined(PERL_IMPLICIT_CONTEXT)
4500   pTHX = NULL;
4501 #endif
4502   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
4503                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
4504                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4505                                  {          0,                0,    0,      0} };
4506
4507 #ifdef KILL_BY_SIGPRC
4508     (void) Perl_csighandler_init();
4509 #endif
4510
4511   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4512   _ckvmssts_noperl(iosb[0]);
4513   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4514     if (iprv[i]) {           /* Running image installed with privs? */
4515       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
4516       will_taint = TRUE;
4517       break;
4518     }
4519   }
4520   /* Rights identifiers might trigger tainting as well. */
4521   if (!will_taint && (rlen || rsz)) {
4522     while (rlen < rsz) {
4523       /* We didn't get all the identifiers on the first pass.  Allocate a
4524        * buffer much larger than $GETJPI wants (rsz is size in bytes that
4525        * were needed to hold all identifiers at time of last call; we'll
4526        * allocate that many unsigned long ints), and go back and get 'em.
4527        * If it gave us less than it wanted to despite ample buffer space,
4528        * something's broken.  Is your system missing a system identifier?
4529        */
4530       if (rsz <= jpilist[1].buflen) {
4531          /* Perl_croak accvios when used this early in startup. */
4532          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4533                          rsz, (unsigned long) jpilist[1].buflen,
4534                          "Check your rights database for corruption.\n");
4535          exit(SS$_ABORT);
4536       }
4537       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4538       jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4539       jpilist[1].buflen = rsz * sizeof(unsigned long int);
4540       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4541       _ckvmssts_noperl(iosb[0]);
4542     }
4543     mask = jpilist[1].bufadr;
4544     /* Check attribute flags for each identifier (2nd longword); protected
4545      * subsystem identifiers trigger tainting.
4546      */
4547     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4548       if (mask[i] & KGB$M_SUBSYSTEM) {
4549         will_taint = TRUE;
4550         break;
4551       }
4552     }
4553     if (mask != rlst) Safefree(mask);
4554   }
4555   /* We need to use this hack to tell Perl it should run with tainting,
4556    * since its tainting flag may be part of the PL_curinterp struct, which
4557    * hasn't been allocated when vms_image_init() is called.
4558    */
4559   if (will_taint) {
4560     char **newargv, **oldargv;
4561     oldargv = *argvp;
4562     New(1320,newargv,(*argcp)+2,char *);
4563     newargv[0] = oldargv[0];
4564     New(1320,newargv[1],3,char);
4565     strcpy(newargv[1], "-T");
4566     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
4567     (*argcp)++;
4568     newargv[*argcp] = NULL;
4569     /* We orphan the old argv, since we don't know where it's come from,
4570      * so we don't know how to free it.
4571      */
4572     *argvp = newargv;
4573   }
4574   else {  /* Did user explicitly request tainting? */
4575     int i;
4576     char *cp, **av = *argvp;
4577     for (i = 1; i < *argcp; i++) {
4578       if (*av[i] != '-') break;
4579       for (cp = av[i]+1; *cp; cp++) {
4580         if (*cp == 'T') { will_taint = 1; break; }
4581         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4582                   strchr("DFIiMmx",*cp)) break;
4583       }
4584       if (will_taint) break;
4585     }
4586   }
4587
4588   for (tabidx = 0;
4589        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4590        tabidx++) {
4591     if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4592     else if (tabidx >= tabct) {
4593       tabct += 8;
4594       Renew(tabvec,tabct,struct dsc$descriptor_s *);
4595     }
4596     New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4597     tabvec[tabidx]->dsc$w_length  = 0;
4598     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
4599     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
4600     tabvec[tabidx]->dsc$a_pointer = NULL;
4601     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4602   }
4603   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4604
4605   getredirection(argcp,argvp);
4606   return;
4607 }
4608 /*}}}*/
4609
4610
4611 /* trim_unixpath()
4612  * Trim Unix-style prefix off filespec, so it looks like what a shell
4613  * glob expansion would return (i.e. from specified prefix on, not
4614  * full path).  Note that returned filespec is Unix-style, regardless
4615  * of whether input filespec was VMS-style or Unix-style.
4616  *
4617  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4618  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
4619  * vector of options; at present, only bit 0 is used, and if set tells
4620  * trim unixpath to try the current default directory as a prefix when
4621  * presented with a possibly ambiguous ... wildcard.
4622  *
4623  * Returns !=0 on success, with trimmed filespec replacing contents of
4624  * fspec, and 0 on failure, with contents of fpsec unchanged.
4625  */
4626 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4627 int
4628 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4629 {
4630   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4631        *template, *base, *end, *cp1, *cp2;
4632   register int tmplen, reslen = 0, dirs = 0;
4633
4634   if (!wildspec || !fspec) return 0;
4635   if (strpbrk(wildspec,"]>:") != NULL) {
4636     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4637     else template = unixwild;
4638   }
4639   else template = wildspec;
4640   if (strpbrk(fspec,"]>:") != NULL) {
4641     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4642     else base = unixified;
4643     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4644      * check to see that final result fits into (isn't longer than) fspec */
4645     reslen = strlen(fspec);
4646   }
4647   else base = fspec;
4648
4649   /* No prefix or absolute path on wildcard, so nothing to remove */
4650   if (!*template || *template == '/') {
4651     if (base == fspec) return 1;
4652     tmplen = strlen(unixified);
4653     if (tmplen > reslen) return 0;  /* not enough space */
4654     /* Copy unixified resultant, including trailing NUL */
4655     memmove(fspec,unixified,tmplen+1);
4656     return 1;
4657   }
4658
4659   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
4660   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4661     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4662     for (cp1 = end ;cp1 >= base; cp1--)
4663       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4664         { cp1++; break; }
4665     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4666     return 1;
4667   }
4668   else {
4669     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4670     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4671     int ells = 1, totells, segdirs, match;
4672     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4673                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4674
4675     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4676     totells = ells;
4677     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4678     if (ellipsis == template && opts & 1) {
4679       /* Template begins with an ellipsis.  Since we can't tell how many
4680        * directory names at the front of the resultant to keep for an
4681        * arbitrary starting point, we arbitrarily choose the current
4682        * default directory as a starting point.  If it's there as a prefix,
4683        * clip it off.  If not, fall through and act as if the leading
4684        * ellipsis weren't there (i.e. return shortest possible path that
4685        * could match template).
4686        */
4687       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4688       for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4689         if (_tolower(*cp1) != _tolower(*cp2)) break;
4690       segdirs = dirs - totells;  /* Min # of dirs we must have left */
4691       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4692       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4693         memcpy(fspec,cp2+1,end - cp2);
4694         return 1;
4695       }
4696     }
4697     /* First off, back up over constant elements at end of path */
4698     if (dirs) {
4699       for (front = end ; front >= base; front--)
4700          if (*front == '/' && !dirs--) { front++; break; }
4701     }
4702     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4703          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
4704     if (cp1 != '\0') return 0;  /* Path too long. */
4705     lcend = cp2;
4706     *cp2 = '\0';  /* Pick up with memcpy later */
4707     lcfront = lcres + (front - base);
4708     /* Now skip over each ellipsis and try to match the path in front of it. */
4709     while (ells--) {
4710       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4711         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
4712             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
4713       if (cp1 < template) break; /* template started with an ellipsis */
4714       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4715         ellipsis = cp1; continue;
4716       }
4717       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4718       nextell = cp1;
4719       for (segdirs = 0, cp2 = tpl;
4720            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4721            cp1++, cp2++) {
4722          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4723          else *cp2 = _tolower(*cp1);  /* else lowercase for match */
4724          if (*cp2 == '/') segdirs++;
4725       }
4726       if (cp1 != ellipsis - 1) return 0; /* Path too long */
4727       /* Back up at least as many dirs as in template before matching */
4728       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4729         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4730       for (match = 0; cp1 > lcres;) {
4731         resdsc.dsc$a_pointer = cp1;
4732         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4733           match++;
4734           if (match == 1) lcfront = cp1;
4735         }
4736         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4737       }
4738       if (!match) return 0;  /* Can't find prefix ??? */
4739       if (match > 1 && opts & 1) {
4740         /* This ... wildcard could cover more than one set of dirs (i.e.
4741          * a set of similar dir names is repeated).  If the template
4742          * contains more than 1 ..., upstream elements could resolve the
4743          * ambiguity, but it's not worth a full backtracking setup here.
4744          * As a quick heuristic, clip off the current default directory
4745          * if it's present to find the trimmed spec, else use the
4746          * shortest string that this ... could cover.
4747          */
4748         char def[NAM$C_MAXRSS+1], *st;
4749
4750         if (getcwd(def, sizeof def,0) == NULL) return 0;
4751         for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4752           if (_tolower(*cp1) != _tolower(*cp2)) break;
4753         segdirs = dirs - totells;  /* Min # of dirs we must have left */
4754         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4755         if (*cp1 == '\0' && *cp2 == '/') {
4756           memcpy(fspec,cp2+1,end - cp2);
4757           return 1;
4758         }
4759         /* Nope -- stick with lcfront from above and keep going. */
4760       }
4761     }
4762     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4763     return 1;
4764     ellipsis = nextell;
4765   }
4766
4767 }  /* end of trim_unixpath() */
4768 /*}}}*/
4769
4770
4771 /*
4772  *  VMS readdir() routines.
4773  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4774  *
4775  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
4776  *  Minor modifications to original routines.
4777  */
4778
4779     /* Number of elements in vms_versions array */
4780 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
4781
4782 /*
4783  *  Open a directory, return a handle for later use.
4784  */
4785 /*{{{ DIR *opendir(char*name) */
4786 DIR *
4787 Perl_opendir(pTHX_ char *name)
4788 {
4789     DIR *dd;
4790     char dir[NAM$C_MAXRSS+1];
4791     Stat_t sb;
4792
4793     if (do_tovmspath(name,dir,0) == NULL) {
4794       return NULL;
4795     }
4796     /* Check access before stat; otherwise stat does not
4797      * accurately report whether it's a directory.
4798      */
4799     if (!cando_by_name(S_IRUSR,0,dir)) {
4800       /* cando_by_name has already set errno */
4801       return NULL;
4802     }
4803     if (flex_stat(dir,&sb) == -1) return NULL;
4804     if (!S_ISDIR(sb.st_mode)) {
4805       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
4806       return NULL;
4807     }
4808     /* Get memory for the handle, and the pattern. */
4809     New(1306,dd,1,DIR);
4810     New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4811
4812     /* Fill in the fields; mainly playing with the descriptor. */
4813     (void)sprintf(dd->pattern, "%s*.*",dir);
4814     dd->context = 0;
4815     dd->count = 0;
4816     dd->vms_wantversions = 0;
4817     dd->pat.dsc$a_pointer = dd->pattern;
4818     dd->pat.dsc$w_length = strlen(dd->pattern);
4819     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4820     dd->pat.dsc$b_class = DSC$K_CLASS_S;
4821
4822     return dd;
4823 }  /* end of opendir() */
4824 /*}}}*/
4825
4826 /*
4827  *  Set the flag to indicate we want versions or not.
4828  */
4829 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4830 void
4831 vmsreaddirversions(DIR *dd, int flag)
4832 {
4833     dd->vms_wantversions = flag;
4834 }
4835 /*}}}*/
4836
4837 /*
4838  *  Free up an opened directory.
4839  */
4840 /*{{{ void closedir(DIR *dd)*/
4841 void
4842 closedir(DIR *dd)
4843 {
4844     (void)lib$find_file_end(&dd->context);
4845     Safefree(dd->pattern);
4846     Safefree((char *)dd);
4847 }
4848 /*}}}*/
4849
4850 /*
4851  *  Collect all the version numbers for the current file.
4852  */
4853 static void
4854 collectversions(pTHX_ DIR *dd)
4855 {
4856     struct dsc$descriptor_s     pat;
4857     struct dsc$descriptor_s     res;
4858     struct dirent *e;
4859     char *p, *text, buff[sizeof dd->entry.d_name];
4860     int i;
4861     unsigned long context, tmpsts;
4862
4863     /* Convenient shorthand. */
4864     e = &dd->entry;
4865
4866     /* Add the version wildcard, ignoring the "*.*" put on before */
4867     i = strlen(dd->pattern);
4868     New(1308,text,i + e->d_namlen + 3,char);
4869     (void)strcpy(text, dd->pattern);
4870     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4871
4872     /* Set up the pattern descriptor. */
4873     pat.dsc$a_pointer = text;
4874     pat.dsc$w_length = i + e->d_namlen - 1;
4875     pat.dsc$b_dtype = DSC$K_DTYPE_T;
4876     pat.dsc$b_class = DSC$K_CLASS_S;
4877
4878     /* Set up result descriptor. */
4879     res.dsc$a_pointer = buff;
4880     res.dsc$w_length = sizeof buff - 2;
4881     res.dsc$b_dtype = DSC$K_DTYPE_T;
4882     res.dsc$b_class = DSC$K_CLASS_S;
4883
4884     /* Read files, collecting versions. */
4885     for (context = 0, e->vms_verscount = 0;
4886          e->vms_verscount < VERSIZE(e);
4887          e->vms_verscount++) {
4888         tmpsts = lib$find_file(&pat, &res, &context);
4889         if (tmpsts == RMS$_NMF || context == 0) break;
4890         _ckvmssts(tmpsts);
4891         buff[sizeof buff - 1] = '\0';
4892         if ((p = strchr(buff, ';')))
4893             e->vms_versions[e->vms_verscount] = atoi(p + 1);
4894         else
4895             e->vms_versions[e->vms_verscount] = -1;
4896     }
4897
4898     _ckvmssts(lib$find_file_end(&context));
4899     Safefree(text);
4900
4901 }  /* end of collectversions() */
4902
4903 /*
4904  *  Read the next entry from the directory.
4905  */
4906 /*{{{ struct dirent *readdir(DIR *dd)*/
4907 struct dirent *
4908 Perl_readdir(pTHX_ DIR *dd)
4909 {
4910     struct dsc$descriptor_s     res;
4911     char *p, buff[sizeof dd->entry.d_name];
4912     unsigned long int tmpsts;
4913
4914     /* Set up result descriptor, and get next file. */
4915     res.dsc$a_pointer = buff;
4916     res.dsc$w_length = sizeof buff - 2;
4917     res.dsc$b_dtype = DSC$K_DTYPE_T;
4918     res.dsc$b_class = DSC$K_CLASS_S;
4919     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4920     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
4921     if (!(tmpsts & 1)) {
4922       set_vaxc_errno(tmpsts);
4923       switch (tmpsts) {
4924         case RMS$_PRV:
4925           set_errno(EACCES); break;
4926         case RMS$_DEV:
4927           set_errno(ENODEV); break;
4928         case RMS$_DIR:
4929           set_errno(ENOTDIR); break;
4930         case RMS$_FNF: case RMS$_DNF:
4931           set_errno(ENOENT); break;
4932         default:
4933           set_errno(EVMSERR);
4934       }
4935       return NULL;
4936     }
4937     dd->count++;
4938     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4939     buff[sizeof buff - 1] = '\0';
4940     for (p = buff; *p; p++) *p = _tolower(*p);
4941     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
4942     *p = '\0';
4943
4944     /* Skip any directory component and just copy the name. */
4945     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4946     else (void)strcpy(dd->entry.d_name, buff);
4947
4948     /* Clobber the version. */
4949     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4950
4951     dd->entry.d_namlen = strlen(dd->entry.d_name);
4952     dd->entry.vms_verscount = 0;
4953     if (dd->vms_wantversions) collectversions(aTHX_ dd);
4954     return &dd->entry;
4955
4956 }  /* end of readdir() */
4957 /*}}}*/
4958
4959 /*
4960  *  Return something that can be used in a seekdir later.
4961  */
4962 /*{{{ long telldir(DIR *dd)*/
4963 long
4964 telldir(DIR *dd)
4965 {
4966     return dd->count;
4967 }
4968 /*}}}*/
4969
4970 /*
4971  *  Return to a spot where we used to be.  Brute force.
4972  */
4973 /*{{{ void seekdir(DIR *dd,long count)*/
4974 void
4975 Perl_seekdir(pTHX_ DIR *dd, long count)
4976 {
4977     int vms_wantversions;
4978
4979     /* If we haven't done anything yet... */
4980     if (dd->count == 0)
4981         return;
4982
4983     /* Remember some state, and clear it. */
4984     vms_wantversions = dd->vms_wantversions;
4985     dd->vms_wantversions = 0;
4986     _ckvmssts(lib$find_file_end(&dd->context));
4987     dd->context = 0;
4988
4989     /* The increment is in readdir(). */
4990     for (dd->count = 0; dd->count < count; )
4991         (void)readdir(dd);
4992
4993     dd->vms_wantversions = vms_wantversions;
4994
4995 }  /* end of seekdir() */
4996 /*}}}*/
4997
4998 /* VMS subprocess management
4999  *
5000  * my_vfork() - just a vfork(), after setting a flag to record that
5001  * the current script is trying a Unix-style fork/exec.
5002  *
5003  * vms_do_aexec() and vms_do_exec() are called in response to the
5004  * perl 'exec' function.  If this follows a vfork call, then they
5005  * call out the regular perl routines in doio.c which do an
5006  * execvp (for those who really want to try this under VMS).
5007  * Otherwise, they do exactly what the perl docs say exec should
5008  * do - terminate the current script and invoke a new command
5009  * (See below for notes on command syntax.)
5010  *
5011  * do_aspawn() and do_spawn() implement the VMS side of the perl
5012  * 'system' function.
5013  *
5014  * Note on command arguments to perl 'exec' and 'system': When handled
5015  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
5016  * are concatenated to form a DCL command string.  If the first arg
5017  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
5018  * the command string is handed off to DCL directly.  Otherwise,
5019  * the first token of the command is taken as the filespec of an image
5020  * to run.  The filespec is expanded using a default type of '.EXE' and
5021  * the process defaults for device, directory, etc., and if found, the resultant
5022  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
5023  * the command string as parameters.  This is perhaps a bit complicated,
5024  * but I hope it will form a happy medium between what VMS folks expect
5025  * from lib$spawn and what Unix folks expect from exec.
5026  */
5027
5028 static int vfork_called;
5029
5030 /*{{{int my_vfork()*/
5031 int
5032 my_vfork()
5033 {
5034   vfork_called++;
5035   return vfork();
5036 }
5037 /*}}}*/
5038
5039
5040 static void
5041 vms_execfree(struct dsc$descriptor_s *vmscmd)
5042 {
5043   if (vmscmd) {
5044       if (vmscmd->dsc$a_pointer) {
5045           Safefree(vmscmd->dsc$a_pointer);
5046       }
5047       Safefree(vmscmd);
5048   }
5049 }
5050
5051 static char *
5052 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
5053 {
5054   char *junk, *tmps = Nullch;
5055   register size_t cmdlen = 0;
5056   size_t rlen;
5057   register SV **idx;
5058   STRLEN n_a;
5059
5060   idx = mark;
5061   if (really) {
5062     tmps = SvPV(really,rlen);
5063     if (*tmps) {
5064       cmdlen += rlen + 1;
5065       idx++;
5066     }
5067   }
5068
5069   for (idx++; idx <= sp; idx++) {
5070     if (*idx) {
5071       junk = SvPVx(*idx,rlen);
5072       cmdlen += rlen ? rlen + 1 : 0;
5073     }
5074   }
5075   New(401,PL_Cmd,cmdlen+1,char);
5076
5077   if (tmps && *tmps) {
5078     strcpy(PL_Cmd,tmps);
5079     mark++;
5080   }
5081   else *PL_Cmd = '\0';
5082   while (++mark <= sp) {
5083     if (*mark) {
5084       char *s = SvPVx(*mark,n_a);
5085       if (!*s) continue;
5086       if (*PL_Cmd) strcat(PL_Cmd," ");
5087       strcat(PL_Cmd,s);
5088     }
5089   }
5090   return PL_Cmd;
5091
5092 }  /* end of setup_argstr() */
5093
5094
5095 static unsigned long int
5096 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5097                    struct dsc$descriptor_s **pvmscmd)
5098 {
5099   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5100   $DESCRIPTOR(defdsc,".EXE");
5101   $DESCRIPTOR(defdsc2,".");
5102   $DESCRIPTOR(resdsc,resspec);
5103   struct dsc$descriptor_s *vmscmd;
5104   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5105   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5106   register char *s, *rest, *cp, *wordbreak;
5107   register int isdcl;
5108
5109   New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5110   vmscmd->dsc$a_pointer = NULL;
5111   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
5112   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
5113   vmscmd->dsc$w_length = 0;
5114   if (pvmscmd) *pvmscmd = vmscmd;
5115
5116   if (suggest_quote) *suggest_quote = 0;
5117
5118   if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5119     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
5120   s = cmd;
5121   while (*s && isspace(*s)) s++;
5122
5123   if (*s == '@' || *s == '$') {
5124     vmsspec[0] = *s;  rest = s + 1;
5125     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5126   }
5127   else { cp = vmsspec; rest = s; }
5128   if (*rest == '.' || *rest == '/') {
5129     char *cp2;
5130     for (cp2 = resspec;
5131          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5132          rest++, cp2++) *cp2 = *rest;
5133     *cp2 = '\0';
5134     if (do_tovmsspec(resspec,cp,0)) {
5135       s = vmsspec;
5136       if (*rest) {
5137         for (cp2 = vmsspec + strlen(vmsspec);
5138              *rest && cp2 - vmsspec < sizeof vmsspec;
5139              rest++, cp2++) *cp2 = *rest;
5140         *cp2 = '\0';
5141       }
5142     }
5143   }
5144   /* Intuit whether verb (first word of cmd) is a DCL command:
5145    *   - if first nonspace char is '@', it's a DCL indirection
5146    * otherwise
5147    *   - if verb contains a filespec separator, it's not a DCL command
5148    *   - if it doesn't, caller tells us whether to default to a DCL
5149    *     command, or to a local image unless told it's DCL (by leading '$')
5150    */
5151   if (*s == '@') {
5152       isdcl = 1;
5153       if (suggest_quote) *suggest_quote = 1;
5154   } else {
5155     register char *filespec = strpbrk(s,":<[.;");
5156     rest = wordbreak = strpbrk(s," \"\t/");
5157     if (!wordbreak) wordbreak = s + strlen(s);
5158     if (*s == '$') check_img = 0;
5159     if (filespec && (filespec < wordbreak)) isdcl = 0;
5160     else isdcl = !check_img;
5161   }
5162
5163   if (!isdcl) {
5164     imgdsc.dsc$a_pointer = s;
5165     imgdsc.dsc$w_length = wordbreak - s;
5166     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5167     if (!(retsts&1)) {
5168         _ckvmssts(lib$find_file_end(&cxt));
5169         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5170     if (!(retsts & 1) && *s == '$') {
5171           _ckvmssts(lib$find_file_end(&cxt));
5172       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5173       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5174           if (!(retsts&1)) {
5175       _ckvmssts(lib$find_file_end(&cxt));
5176             retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5177           }
5178     }
5179     }
5180     _ckvmssts(lib$find_file_end(&cxt));
5181
5182     if (retsts & 1) {
5183       FILE *fp;
5184       s = resspec;
5185       while (*s && !isspace(*s)) s++;
5186       *s = '\0';
5187
5188       /* check that it's really not DCL with no file extension */
5189       fp = fopen(resspec,"r","ctx=bin,shr=get");
5190       if (fp) {
5191         char b[4] = {0,0,0,0};
5192         read(fileno(fp),b,4);
5193         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5194         fclose(fp);
5195       }
5196       if (check_img && isdcl) return RMS$_FNF;
5197
5198       if (cando_by_name(S_IXUSR,0,resspec)) {
5199         New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5200         if (!isdcl) {
5201             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5202             if (suggest_quote) *suggest_quote = 1;
5203         } else {
5204             strcpy(vmscmd->dsc$a_pointer,"@");
5205             if (suggest_quote) *suggest_quote = 1;
5206         }
5207         strcat(vmscmd->dsc$a_pointer,resspec);
5208         if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5209         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5210         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5211       }
5212       else retsts = RMS$_PRV;
5213     }
5214   }
5215   /* It's either a DCL command or we couldn't find a suitable image */
5216   vmscmd->dsc$w_length = strlen(cmd);
5217 /*  if (cmd == PL_Cmd) {
5218       vmscmd->dsc$a_pointer = PL_Cmd;
5219       if (suggest_quote) *suggest_quote = 1;
5220   }
5221   else  */
5222       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5223
5224   /* check if it's a symbol (for quoting purposes) */
5225   if (suggest_quote && !*suggest_quote) {
5226     int iss;
5227     char equiv[LNM$C_NAMLENGTH];
5228     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5229     eqvdsc.dsc$a_pointer = equiv;
5230
5231     iss = lib$get_symbol(vmscmd,&eqvdsc);
5232     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5233   }
5234   if (!(retsts & 1)) {
5235     /* just hand off status values likely to be due to user error */
5236     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5237         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5238        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5239     else { _ckvmssts(retsts); }
5240   }
5241
5242   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5243
5244 }  /* end of setup_cmddsc() */
5245
5246
5247 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5248 bool
5249 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5250 {
5251   if (sp > mark) {
5252     if (vfork_called) {           /* this follows a vfork - act Unixish */
5253       vfork_called--;
5254       if (vfork_called < 0) {
5255         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5256         vfork_called = 0;
5257       }
5258       else return do_aexec(really,mark,sp);
5259     }
5260                                            /* no vfork - act VMSish */
5261     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5262
5263   }
5264
5265   return FALSE;
5266 }  /* end of vms_do_aexec() */
5267 /*}}}*/
5268
5269 /* {{{bool vms_do_exec(char *cmd) */
5270 bool
5271 Perl_vms_do_exec(pTHX_ char *cmd)
5272 {
5273   struct dsc$descriptor_s *vmscmd;
5274
5275   if (vfork_called) {             /* this follows a vfork - act Unixish */
5276     vfork_called--;
5277     if (vfork_called < 0) {
5278       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5279       vfork_called = 0;
5280     }
5281     else return do_exec(cmd);
5282   }
5283
5284   {                               /* no vfork - act VMSish */
5285     unsigned long int retsts;
5286
5287     TAINT_ENV();
5288     TAINT_PROPER("exec");
5289     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5290       retsts = lib$do_command(vmscmd);
5291
5292     switch (retsts) {
5293       case RMS$_FNF: case RMS$_DNF:
5294         set_errno(ENOENT); break;
5295       case RMS$_DIR:
5296         set_errno(ENOTDIR); break;
5297       case RMS$_DEV:
5298         set_errno(ENODEV); break;
5299       case RMS$_PRV:
5300         set_errno(EACCES); break;
5301       case RMS$_SYN:
5302         set_errno(EINVAL); break;
5303       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5304         set_errno(E2BIG); break;
5305       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5306         _ckvmssts(retsts); /* fall through */
5307       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5308         set_errno(EVMSERR);
5309     }
5310     set_vaxc_errno(retsts);
5311     if (ckWARN(WARN_EXEC)) {
5312       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5313              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5314     }
5315     vms_execfree(vmscmd);
5316   }
5317
5318   return FALSE;
5319
5320 }  /* end of vms_do_exec() */
5321 /*}}}*/
5322
5323 unsigned long int Perl_do_spawn(pTHX_ char *);
5324
5325 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5326 unsigned long int
5327 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5328 {
5329   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5330
5331   return SS$_ABORT;
5332 }  /* end of do_aspawn() */
5333 /*}}}*/
5334
5335 /* {{{unsigned long int do_spawn(char *cmd) */
5336 unsigned long int
5337 Perl_do_spawn(pTHX_ char *cmd)
5338 {
5339   unsigned long int sts, substs;
5340
5341   TAINT_ENV();
5342   TAINT_PROPER("spawn");
5343   if (!cmd || !*cmd) {
5344     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5345     if (!(sts & 1)) {
5346       switch (sts) {
5347         case RMS$_FNF:  case RMS$_DNF:
5348           set_errno(ENOENT); break;
5349         case RMS$_DIR:
5350           set_errno(ENOTDIR); break;
5351         case RMS$_DEV:
5352           set_errno(ENODEV); break;
5353         case RMS$_PRV:
5354           set_errno(EACCES); break;
5355         case RMS$_SYN:
5356           set_errno(EINVAL); break;
5357         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5358           set_errno(E2BIG); break;
5359         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5360           _ckvmssts(sts); /* fall through */
5361         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5362           set_errno(EVMSERR);
5363       }
5364       set_vaxc_errno(sts);
5365       if (ckWARN(WARN_EXEC)) {
5366         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5367                     Strerror(errno));
5368       }
5369     }
5370     sts = substs;
5371   }
5372   else {
5373     (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5374   }
5375   return sts;
5376 }  /* end of do_spawn() */
5377 /*}}}*/
5378
5379
5380 static unsigned int *sockflags, sockflagsize;
5381
5382 /*
5383  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5384  * routines found in some versions of the CRTL can't deal with sockets.
5385  * We don't shim the other file open routines since a socket isn't
5386  * likely to be opened by a name.
5387  */
5388 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5389 FILE *my_fdopen(int fd, const char *mode)
5390 {
5391   FILE *fp = fdopen(fd, (char *) mode);
5392
5393   if (fp) {
5394     unsigned int fdoff = fd / sizeof(unsigned int);
5395     struct stat sbuf; /* native stat; we don't need flex_stat */
5396     if (!sockflagsize || fdoff > sockflagsize) {
5397       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
5398       else           New  (1324,sockflags,fdoff+2,unsigned int);
5399       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5400       sockflagsize = fdoff + 2;
5401     }
5402     if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5403       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5404   }
5405   return fp;
5406
5407 }
5408 /*}}}*/
5409
5410
5411 /*
5412  * Clear the corresponding bit when the (possibly) socket stream is closed.
5413  * There still a small hole: we miss an implicit close which might occur
5414  * via freopen().  >> Todo
5415  */
5416 /*{{{ int my_fclose(FILE *fp)*/
5417 int my_fclose(FILE *fp) {
5418   if (fp) {
5419     unsigned int fd = fileno(fp);
5420     unsigned int fdoff = fd / sizeof(unsigned int);
5421
5422     if (sockflagsize && fdoff <= sockflagsize)
5423       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5424   }
5425   return fclose(fp);
5426 }
5427 /*}}}*/
5428
5429
5430 /*
5431  * A simple fwrite replacement which outputs itmsz*nitm chars without
5432  * introducing record boundaries every itmsz chars.
5433  * We are using fputs, which depends on a terminating null.  We may
5434  * well be writing binary data, so we need to accommodate not only
5435  * data with nulls sprinkled in the middle but also data with no null
5436  * byte at the end.
5437  */
5438 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5439 int
5440 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5441 {
5442   register char *cp, *end, *cpd, *data;
5443   register unsigned int fd = fileno(dest);
5444   register unsigned int fdoff = fd / sizeof(unsigned int);
5445   int retval;
5446   int bufsize = itmsz * nitm + 1;
5447
5448   if (fdoff < sockflagsize &&
5449       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5450     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5451     return nitm;
5452   }
5453
5454   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5455   memcpy( data, src, itmsz*nitm );
5456   data[itmsz*nitm] = '\0';
5457
5458   end = data + itmsz * nitm;
5459   retval = (int) nitm; /* on success return # items written */
5460
5461   cpd = data;
5462   while (cpd <= end) {
5463     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5464     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5465     if (cp < end)
5466       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5467     cpd = cp + 1;
5468   }
5469
5470   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5471   return retval;
5472
5473 }  /* end of my_fwrite() */
5474 /*}}}*/
5475
5476 /*{{{ int my_flush(FILE *fp)*/
5477 int
5478 Perl_my_flush(pTHX_ FILE *fp)
5479 {
5480     int res;
5481     if ((res = fflush(fp)) == 0 && fp) {
5482 #ifdef VMS_DO_SOCKETS
5483         Stat_t s;
5484         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5485 #endif
5486             res = fsync(fileno(fp));
5487     }
5488 /*
5489  * If the flush succeeded but set end-of-file, we need to clear
5490  * the error because our caller may check ferror().  BTW, this
5491  * probably means we just flushed an empty file.
5492  */
5493     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5494
5495     return res;
5496 }
5497 /*}}}*/
5498
5499 /*
5500  * Here are replacements for the following Unix routines in the VMS environment:
5501  *      getpwuid    Get information for a particular UIC or UID
5502  *      getpwnam    Get information for a named user
5503  *      getpwent    Get information for each user in the rights database
5504  *      setpwent    Reset search to the start of the rights database
5505  *      endpwent    Finish searching for users in the rights database
5506  *
5507  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5508  * (defined in pwd.h), which contains the following fields:-
5509  *      struct passwd {
5510  *              char        *pw_name;    Username (in lower case)
5511  *              char        *pw_passwd;  Hashed password
5512  *              unsigned int pw_uid;     UIC
5513  *              unsigned int pw_gid;     UIC group  number
5514  *              char        *pw_unixdir; Default device/directory (VMS-style)
5515  *              char        *pw_gecos;   Owner name
5516  *              char        *pw_dir;     Default device/directory (Unix-style)
5517  *              char        *pw_shell;   Default CLI name (eg. DCL)
5518  *      };
5519  * If the specified user does not exist, getpwuid and getpwnam return NULL.
5520  *
5521  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5522  * not the UIC member number (eg. what's returned by getuid()),
5523  * getpwuid() can accept either as input (if uid is specified, the caller's
5524  * UIC group is used), though it won't recognise gid=0.
5525  *
5526  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5527  * information about other users in your group or in other groups, respectively.
5528  * If the required privilege is not available, then these routines fill only
5529  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5530  * string).
5531  *
5532  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5533  */
5534
5535 /* sizes of various UAF record fields */
5536 #define UAI$S_USERNAME 12
5537 #define UAI$S_IDENT    31
5538 #define UAI$S_OWNER    31
5539 #define UAI$S_DEFDEV   31
5540 #define UAI$S_DEFDIR   63
5541 #define UAI$S_DEFCLI   31
5542 #define UAI$S_PWD       8
5543
5544 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
5545                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5546                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
5547
5548 static char __empty[]= "";
5549 static struct passwd __passwd_empty=
5550     {(char *) __empty, (char *) __empty, 0, 0,
5551      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5552 static int contxt= 0;
5553 static struct passwd __pwdcache;
5554 static char __pw_namecache[UAI$S_IDENT+1];
5555
5556 /*
5557  * This routine does most of the work extracting the user information.
5558  */
5559 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5560 {
5561     static struct {
5562         unsigned char length;
5563         char pw_gecos[UAI$S_OWNER+1];
5564     } owner;
5565     static union uicdef uic;
5566     static struct {
5567         unsigned char length;
5568         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5569     } defdev;
5570     static struct {
5571         unsigned char length;
5572         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5573     } defdir;
5574     static struct {
5575         unsigned char length;
5576         char pw_shell[UAI$S_DEFCLI+1];
5577     } defcli;
5578     static char pw_passwd[UAI$S_PWD+1];
5579
5580     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5581     struct dsc$descriptor_s name_desc;
5582     unsigned long int sts;
5583
5584     static struct itmlst_3 itmlst[]= {
5585         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
5586         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
5587         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
5588         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
5589         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
5590         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
5591         {0,                0,           NULL,    NULL}};
5592
5593     name_desc.dsc$w_length=  strlen(name);
5594     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5595     name_desc.dsc$b_class=   DSC$K_CLASS_S;
5596     name_desc.dsc$a_pointer= (char *) name;
5597
5598 /*  Note that sys$getuai returns many fields as counted strings. */
5599     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5600     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5601       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5602     }
5603     else { _ckvmssts(sts); }
5604     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
5605
5606     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
5607     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5608     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5609     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5610     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5611     owner.pw_gecos[lowner]=            '\0';
5612     defdev.pw_dir[ldefdev+ldefdir]= '\0';
5613     defcli.pw_shell[ldefcli]=          '\0';
5614     if (valid_uic(uic)) {
5615         pwd->pw_uid= uic.uic$l_uic;
5616         pwd->pw_gid= uic.uic$v_group;
5617     }
5618     else
5619       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5620     pwd->pw_passwd=  pw_passwd;
5621     pwd->pw_gecos=   owner.pw_gecos;
5622     pwd->pw_dir=     defdev.pw_dir;
5623     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5624     pwd->pw_shell=   defcli.pw_shell;
5625     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5626         int ldir;
5627         ldir= strlen(pwd->pw_unixdir) - 1;
5628         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5629     }
5630     else
5631         strcpy(pwd->pw_unixdir, pwd->pw_dir);
5632     __mystrtolower(pwd->pw_unixdir);
5633     return 1;
5634 }
5635
5636 /*
5637  * Get information for a named user.
5638 */
5639 /*{{{struct passwd *getpwnam(char *name)*/
5640 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5641 {
5642     struct dsc$descriptor_s name_desc;
5643     union uicdef uic;
5644     unsigned long int status, sts;
5645
5646     __pwdcache = __passwd_empty;
5647     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5648       /* We still may be able to determine pw_uid and pw_gid */
5649       name_desc.dsc$w_length=  strlen(name);
5650       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5651       name_desc.dsc$b_class=   DSC$K_CLASS_S;
5652       name_desc.dsc$a_pointer= (char *) name;
5653       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5654         __pwdcache.pw_uid= uic.uic$l_uic;
5655         __pwdcache.pw_gid= uic.uic$v_group;
5656       }
5657       else {
5658         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5659           set_vaxc_errno(sts);
5660           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5661           return NULL;
5662         }
5663         else { _ckvmssts(sts); }
5664       }
5665     }
5666     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5667     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5668     __pwdcache.pw_name= __pw_namecache;
5669     return &__pwdcache;
5670 }  /* end of my_getpwnam() */
5671 /*}}}*/
5672
5673 /*
5674  * Get information for a particular UIC or UID.
5675  * Called by my_getpwent with uid=-1 to list all users.
5676 */
5677 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5678 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5679 {
5680     const $DESCRIPTOR(name_desc,__pw_namecache);
5681     unsigned short lname;
5682     union uicdef uic;
5683     unsigned long int status;
5684
5685     if (uid == (unsigned int) -1) {
5686       do {
5687         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5688         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5689           set_vaxc_errno(status);
5690           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5691           my_endpwent();
5692           return NULL;
5693         }
5694         else { _ckvmssts(status); }
5695       } while (!valid_uic (uic));
5696     }
5697     else {
5698       uic.uic$l_uic= uid;
5699       if (!uic.uic$v_group)
5700         uic.uic$v_group= PerlProc_getgid();
5701       if (valid_uic(uic))
5702         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5703       else status = SS$_IVIDENT;
5704       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5705           status == RMS$_PRV) {
5706         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5707         return NULL;
5708       }
5709       else { _ckvmssts(status); }
5710     }
5711     __pw_namecache[lname]= '\0';
5712     __mystrtolower(__pw_namecache);
5713
5714     __pwdcache = __passwd_empty;
5715     __pwdcache.pw_name = __pw_namecache;
5716
5717 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5718     The identifier's value is usually the UIC, but it doesn't have to be,
5719     so if we can, we let fillpasswd update this. */
5720     __pwdcache.pw_uid =  uic.uic$l_uic;
5721     __pwdcache.pw_gid =  uic.uic$v_group;
5722
5723     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5724     return &__pwdcache;
5725
5726 }  /* end of my_getpwuid() */
5727 /*}}}*/
5728
5729 /*
5730  * Get information for next user.
5731 */
5732 /*{{{struct passwd *my_getpwent()*/
5733 struct passwd *Perl_my_getpwent(pTHX)
5734 {
5735     return (my_getpwuid((unsigned int) -1));
5736 }
5737 /*}}}*/
5738
5739 /*
5740  * Finish searching rights database for users.
5741 */
5742 /*{{{void my_endpwent()*/
5743 void Perl_my_endpwent(pTHX)
5744 {
5745     if (contxt) {
5746       _ckvmssts(sys$finish_rdb(&contxt));
5747       contxt= 0;
5748     }
5749 }
5750 /*}}}*/
5751
5752 #ifdef HOMEGROWN_POSIX_SIGNALS
5753   /* Signal handling routines, pulled into the core from POSIX.xs.
5754    *
5755    * We need these for threads, so they've been rolled into the core,
5756    * rather than left in POSIX.xs.
5757    *
5758    * (DRS, Oct 23, 1997)
5759    */
5760
5761   /* sigset_t is atomic under VMS, so these routines are easy */
5762 /*{{{int my_sigemptyset(sigset_t *) */
5763 int my_sigemptyset(sigset_t *set) {
5764     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5765     *set = 0; return 0;
5766 }
5767 /*}}}*/
5768
5769
5770 /*{{{int my_sigfillset(sigset_t *)*/
5771 int my_sigfillset(sigset_t *set) {
5772     int i;
5773     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5774     for (i = 0; i < NSIG; i++) *set |= (1 << i);
5775     return 0;
5776 }
5777 /*}}}*/
5778
5779
5780 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5781 int my_sigaddset(sigset_t *set, int sig) {
5782     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5783     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5784     *set |= (1 << (sig - 1));
5785     return 0;
5786 }
5787 /*}}}*/
5788
5789
5790 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5791 int my_sigdelset(sigset_t *set, int sig) {
5792     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5793     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5794     *set &= ~(1 << (sig - 1));
5795     return 0;
5796 }
5797 /*}}}*/
5798
5799
5800 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5801 int my_sigismember(sigset_t *set, int sig) {
5802     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5803     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5804     return *set & (1 << (sig - 1));
5805 }
5806 /*}}}*/
5807
5808
5809 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5810 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5811     sigset_t tempmask;
5812
5813     /* If set and oset are both null, then things are badly wrong. Bail out. */
5814     if ((oset == NULL) && (set == NULL)) {
5815       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5816       return -1;
5817     }
5818
5819     /* If set's null, then we're just handling a fetch. */
5820     if (set == NULL) {
5821         tempmask = sigblock(0);
5822     }
5823     else {
5824       switch (how) {
5825       case SIG_SETMASK:
5826         tempmask = sigsetmask(*set);
5827         break;
5828       case SIG_BLOCK:
5829         tempmask = sigblock(*set);
5830         break;
5831       case SIG_UNBLOCK:
5832         tempmask = sigblock(0);
5833         sigsetmask(*oset & ~tempmask);
5834         break;
5835       default:
5836         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5837         return -1;
5838       }
5839     }
5840
5841     /* Did they pass us an oset? If so, stick our holding mask into it */
5842     if (oset)
5843       *oset = tempmask;
5844
5845     return 0;
5846 }
5847 /*}}}*/
5848 #endif  /* HOMEGROWN_POSIX_SIGNALS */
5849
5850
5851 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5852  * my_utime(), and flex_stat(), all of which operate on UTC unless
5853  * VMSISH_TIMES is true.
5854  */
5855 /* method used to handle UTC conversions:
5856  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
5857  */
5858 static int gmtime_emulation_type;
5859 /* number of secs to add to UTC POSIX-style time to get local time */
5860 static long int utc_offset_secs;
5861
5862 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5863  * in vmsish.h.  #undef them here so we can call the CRTL routines
5864  * directly.
5865  */
5866 #undef gmtime
5867 #undef localtime
5868 #undef time
5869
5870
5871 /*
5872  * DEC C previous to 6.0 corrupts the behavior of the /prefix
5873  * qualifier with the extern prefix pragma.  This provisional
5874  * hack circumvents this prefix pragma problem in previous
5875  * precompilers.
5876  */
5877 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5878 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5879 #    pragma __extern_prefix save
5880 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
5881 #    define gmtime decc$__utctz_gmtime
5882 #    define localtime decc$__utctz_localtime
5883 #    define time decc$__utc_time
5884 #    pragma __extern_prefix restore
5885
5886      struct tm *gmtime(), *localtime();
5887
5888 #  endif
5889 #endif
5890
5891
5892 static time_t toutc_dst(time_t loc) {
5893   struct tm *rsltmp;
5894
5895   if ((rsltmp = localtime(&loc)) == NULL) return -1;
5896   loc -= utc_offset_secs;
5897   if (rsltmp->tm_isdst) loc -= 3600;
5898   return loc;
5899 }
5900 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
5901        ((gmtime_emulation_type || my_time(NULL)), \
5902        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5903        ((secs) - utc_offset_secs))))
5904
5905 static time_t toloc_dst(time_t utc) {
5906   struct tm *rsltmp;
5907
5908   utc += utc_offset_secs;
5909   if ((rsltmp = localtime(&utc)) == NULL) return -1;
5910   if (rsltmp->tm_isdst) utc += 3600;
5911   return utc;
5912 }
5913 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
5914        ((gmtime_emulation_type || my_time(NULL)), \
5915        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5916        ((secs) + utc_offset_secs))))
5917
5918 #ifndef RTL_USES_UTC
5919 /*
5920
5921     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
5922         DST starts on 1st sun of april      at 02:00  std time
5923             ends on last sun of october     at 02:00  dst time
5924     see the UCX management command reference, SET CONFIG TIMEZONE
5925     for formatting info.
5926
5927     No, it's not as general as it should be, but then again, NOTHING
5928     will handle UK times in a sensible way.
5929 */
5930
5931
5932 /*
5933     parse the DST start/end info:
5934     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5935 */
5936
5937 static char *
5938 tz_parse_startend(char *s, struct tm *w, int *past)
5939 {
5940     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5941     int ly, dozjd, d, m, n, hour, min, sec, j, k;
5942     time_t g;
5943
5944     if (!s)    return 0;
5945     if (!w) return 0;
5946     if (!past) return 0;
5947
5948     ly = 0;
5949     if (w->tm_year % 4        == 0) ly = 1;
5950     if (w->tm_year % 100      == 0) ly = 0;
5951     if (w->tm_year+1900 % 400 == 0) ly = 1;
5952     if (ly) dinm[1]++;
5953
5954     dozjd = isdigit(*s);
5955     if (*s == 'J' || *s == 'j' || dozjd) {
5956         if (!dozjd && !isdigit(*++s)) return 0;
5957         d = *s++ - '0';
5958         if (isdigit(*s)) {
5959             d = d*10 + *s++ - '0';
5960             if (isdigit(*s)) {
5961                 d = d*10 + *s++ - '0';
5962             }
5963         }
5964         if (d == 0) return 0;
5965         if (d > 366) return 0;
5966         d--;
5967         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
5968         g = d * 86400;
5969         dozjd = 1;
5970     } else if (*s == 'M' || *s == 'm') {
5971         if (!isdigit(*++s)) return 0;
5972         m = *s++ - '0';
5973         if (isdigit(*s)) m = 10*m + *s++ - '0';
5974         if (*s != '.') return 0;
5975         if (!isdigit(*++s)) return 0;
5976         n = *s++ - '0';
5977         if (n < 1 || n > 5) return 0;
5978         if (*s != '.') return 0;
5979         if (!isdigit(*++s)) return 0;
5980         d = *s++ - '0';
5981         if (d > 6) return 0;
5982     }
5983
5984     if (*s == '/') {
5985         if (!isdigit(*++s)) return 0;
5986         hour = *s++ - '0';
5987         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5988         if (*s == ':') {
5989             if (!isdigit(*++s)) return 0;
5990             min = *s++ - '0';
5991             if (isdigit(*s)) min = 10*min + *s++ - '0';
5992             if (*s == ':') {
5993                 if (!isdigit(*++s)) return 0;
5994                 sec = *s++ - '0';
5995                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5996             }
5997         }
5998     } else {
5999         hour = 2;
6000         min = 0;
6001         sec = 0;
6002     }
6003
6004     if (dozjd) {
6005         if (w->tm_yday < d) goto before;
6006         if (w->tm_yday > d) goto after;
6007     } else {
6008         if (w->tm_mon+1 < m) goto before;
6009         if (w->tm_mon+1 > m) goto after;
6010
6011         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
6012         k = d - j; /* mday of first d */
6013         if (k <= 0) k += 7;
6014         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
6015         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
6016         if (w->tm_mday < k) goto before;
6017         if (w->tm_mday > k) goto after;
6018     }
6019
6020     if (w->tm_hour < hour) goto before;
6021     if (w->tm_hour > hour) goto after;
6022     if (w->tm_min  < min)  goto before;
6023     if (w->tm_min  > min)  goto after;
6024     if (w->tm_sec  < sec)  goto before;
6025     goto after;
6026
6027 before:
6028     *past = 0;
6029     return s;
6030 after:
6031     *past = 1;
6032     return s;
6033 }
6034
6035
6036
6037
6038 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
6039
6040 static char *
6041 tz_parse_offset(char *s, int *offset)
6042 {
6043     int hour = 0, min = 0, sec = 0;
6044     int neg = 0;
6045     if (!s) return 0;
6046     if (!offset) return 0;
6047
6048     if (*s == '-') {neg++; s++;}
6049     if (*s == '+') s++;
6050     if (!isdigit(*s)) return 0;
6051     hour = *s++ - '0';
6052     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
6053     if (hour > 24) return 0;
6054     if (*s == ':') {
6055         if (!isdigit(*++s)) return 0;
6056         min = *s++ - '0';
6057         if (isdigit(*s)) min = min*10 + (*s++ - '0');
6058         if (min > 59) return 0;
6059         if (*s == ':') {
6060             if (!isdigit(*++s)) return 0;
6061             sec = *s++ - '0';
6062             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
6063             if (sec > 59) return 0;
6064         }
6065     }
6066
6067     *offset = (hour*60+min)*60 + sec;
6068     if (neg) *offset = -*offset;
6069     return s;
6070 }
6071
6072 /*
6073     input time is w, whatever type of time the CRTL localtime() uses.
6074     sets dst, the zone, and the gmtoff (seconds)
6075
6076     caches the value of TZ and UCX$TZ env variables; note that
6077     my_setenv looks for these and sets a flag if they're changed
6078     for efficiency.
6079
6080     We have to watch out for the "australian" case (dst starts in
6081     october, ends in april)...flagged by "reverse" and checked by
6082     scanning through the months of the previous year.
6083
6084 */
6085
6086 static int
6087 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
6088 {
6089     time_t when;
6090     struct tm *w2;
6091     char *s,*s2;
6092     char *dstzone, *tz, *s_start, *s_end;
6093     int std_off, dst_off, isdst;
6094     int y, dststart, dstend;
6095     static char envtz[1025];  /* longer than any logical, symbol, ... */
6096     static char ucxtz[1025];
6097     static char reversed = 0;
6098
6099     if (!w) return 0;
6100
6101     if (tz_updated) {
6102         tz_updated = 0;
6103         reversed = -1;  /* flag need to check  */
6104         envtz[0] = ucxtz[0] = '\0';
6105         tz = my_getenv("TZ",0);
6106         if (tz) strcpy(envtz, tz);
6107         tz = my_getenv("UCX$TZ",0);
6108         if (tz) strcpy(ucxtz, tz);
6109         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
6110     }
6111     tz = envtz;
6112     if (!*tz) tz = ucxtz;
6113
6114     s = tz;
6115     while (isalpha(*s)) s++;
6116     s = tz_parse_offset(s, &std_off);
6117     if (!s) return 0;
6118     if (!*s) {                  /* no DST, hurray we're done! */
6119         isdst = 0;
6120         goto done;
6121     }
6122
6123     dstzone = s;
6124     while (isalpha(*s)) s++;
6125     s2 = tz_parse_offset(s, &dst_off);
6126     if (s2) {
6127         s = s2;
6128     } else {
6129         dst_off = std_off - 3600;
6130     }
6131
6132     if (!*s) {      /* default dst start/end?? */
6133         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
6134             s = strchr(ucxtz,',');
6135         }
6136         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
6137     }
6138     if (*s != ',') return 0;
6139
6140     when = *w;
6141     when = _toutc(when);      /* convert to utc */
6142     when = when - std_off;    /* convert to pseudolocal time*/
6143
6144     w2 = localtime(&when);
6145     y = w2->tm_year;
6146     s_start = s+1;
6147     s = tz_parse_startend(s_start,w2,&dststart);
6148     if (!s) return 0;
6149     if (*s != ',') return 0;
6150
6151     when = *w;
6152     when = _toutc(when);      /* convert to utc */
6153     when = when - dst_off;    /* convert to pseudolocal time*/
6154     w2 = localtime(&when);
6155     if (w2->tm_year != y) {   /* spans a year, just check one time */
6156         when += dst_off - std_off;
6157         w2 = localtime(&when);
6158     }
6159     s_end = s+1;
6160     s = tz_parse_startend(s_end,w2,&dstend);
6161     if (!s) return 0;
6162
6163     if (reversed == -1) {  /* need to check if start later than end */
6164         int j, ds, de;
6165
6166         when = *w;
6167         if (when < 2*365*86400) {
6168             when += 2*365*86400;
6169         } else {
6170             when -= 365*86400;
6171         }
6172         w2 =localtime(&when);
6173         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
6174
6175         for (j = 0; j < 12; j++) {
6176             w2 =localtime(&when);
6177             (void) tz_parse_startend(s_start,w2,&ds);
6178             (void) tz_parse_startend(s_end,w2,&de);
6179             if (ds != de) break;
6180             when += 30*86400;
6181         }
6182         reversed = 0;
6183         if (de && !ds) reversed = 1;
6184     }
6185
6186     isdst = dststart && !dstend;
6187     if (reversed) isdst = dststart  || !dstend;
6188
6189 done:
6190     if (dst)    *dst = isdst;
6191     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6192     if (isdst)  tz = dstzone;
6193     if (zone) {
6194         while(isalpha(*tz))  *zone++ = *tz++;
6195         *zone = '\0';
6196     }
6197     return 1;
6198 }
6199
6200 #endif /* !RTL_USES_UTC */
6201
6202 /* my_time(), my_localtime(), my_gmtime()
6203  * By default traffic in UTC time values, using CRTL gmtime() or
6204  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6205  * Note: We need to use these functions even when the CRTL has working
6206  * UTC support, since they also handle C<use vmsish qw(times);>
6207  *
6208  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
6209  * Modified by Charles Bailey <bailey@newman.upenn.edu>
6210  */
6211
6212 /*{{{time_t my_time(time_t *timep)*/
6213 time_t Perl_my_time(pTHX_ time_t *timep)
6214 {
6215   time_t when;
6216   struct tm *tm_p;
6217
6218   if (gmtime_emulation_type == 0) {
6219     int dstnow;
6220     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
6221                               /* results of calls to gmtime() and localtime() */
6222                               /* for same &base */
6223
6224     gmtime_emulation_type++;
6225     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6226       char off[LNM$C_NAMLENGTH+1];;
6227
6228       gmtime_emulation_type++;
6229       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6230         gmtime_emulation_type++;
6231         utc_offset_secs = 0;
6232         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6233       }
6234       else { utc_offset_secs = atol(off); }
6235     }
6236     else { /* We've got a working gmtime() */
6237       struct tm gmt, local;
6238
6239       gmt = *tm_p;
6240       tm_p = localtime(&base);
6241       local = *tm_p;
6242       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
6243       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6244       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
6245       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
6246     }
6247   }
6248
6249   when = time(NULL);
6250 # ifdef VMSISH_TIME
6251 # ifdef RTL_USES_UTC
6252   if (VMSISH_TIME) when = _toloc(when);
6253 # else
6254   if (!VMSISH_TIME) when = _toutc(when);
6255 # endif
6256 # endif
6257   if (timep != NULL) *timep = when;
6258   return when;
6259
6260 }  /* end of my_time() */
6261 /*}}}*/
6262
6263
6264 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6265 struct tm *
6266 Perl_my_gmtime(pTHX_ const time_t *timep)
6267 {
6268   char *p;
6269   time_t when;
6270   struct tm *rsltmp;
6271
6272   if (timep == NULL) {
6273     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6274     return NULL;
6275   }
6276   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
6277
6278   when = *timep;
6279 # ifdef VMSISH_TIME
6280   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6281 #  endif
6282 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
6283   return gmtime(&when);
6284 # else
6285   /* CRTL localtime() wants local time as input, so does no tz correction */
6286   rsltmp = localtime(&when);
6287   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
6288   return rsltmp;
6289 #endif
6290 }  /* end of my_gmtime() */
6291 /*}}}*/
6292
6293
6294 /*{{{struct tm *my_localtime(const time_t *timep)*/
6295 struct tm *
6296 Perl_my_localtime(pTHX_ const time_t *timep)
6297 {
6298   time_t when, whenutc;
6299   struct tm *rsltmp;
6300   int dst, offset;
6301
6302   if (timep == NULL) {
6303     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6304     return NULL;
6305   }
6306   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
6307   if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6308
6309   when = *timep;
6310 # ifdef RTL_USES_UTC
6311 # ifdef VMSISH_TIME
6312   if (VMSISH_TIME) when = _toutc(when);
6313 # endif
6314   /* CRTL localtime() wants UTC as input, does tz correction itself */
6315   return localtime(&when);
6316
6317 # else /* !RTL_USES_UTC */
6318   whenutc = when;
6319 # ifdef VMSISH_TIME
6320   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
6321   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
6322 # endif
6323   dst = -1;
6324 #ifndef RTL_USES_UTC
6325   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
6326       when = whenutc - offset;                   /* pseudolocal time*/
6327   }
6328 # endif
6329   /* CRTL localtime() wants local time as input, so does no tz correction */
6330   rsltmp = localtime(&when);
6331   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6332   return rsltmp;
6333 # endif
6334
6335 } /*  end of my_localtime() */
6336 /*}}}*/
6337
6338 /* Reset definitions for later calls */
6339 #define gmtime(t)    my_gmtime(t)
6340 #define localtime(t) my_localtime(t)
6341 #define time(t)      my_time(t)
6342
6343
6344 /* my_utime - update modification time of a file
6345  * calling sequence is identical to POSIX utime(), but under
6346  * VMS only the modification time is changed; ODS-2 does not
6347  * maintain access times.  Restrictions differ from the POSIX
6348  * definition in that the time can be changed as long as the
6349  * caller has permission to execute the necessary IO$_MODIFY $QIO;
6350  * no separate checks are made to insure that the caller is the
6351  * owner of the file or has special privs enabled.
6352  * Code here is based on Joe Meadows' FILE utility.
6353  */
6354
6355 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6356  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
6357  * in 100 ns intervals.
6358  */
6359 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6360
6361 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6362 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6363 {
6364   register int i;
6365   long int bintime[2], len = 2, lowbit, unixtime,
6366            secscale = 10000000; /* seconds --> 100 ns intervals */
6367   unsigned long int chan, iosb[2], retsts;
6368   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6369   struct FAB myfab = cc$rms_fab;
6370   struct NAM mynam = cc$rms_nam;
6371 #if defined (__DECC) && defined (__VAX)
6372   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6373    * at least through VMS V6.1, which causes a type-conversion warning.
6374    */
6375 #  pragma message save
6376 #  pragma message disable cvtdiftypes
6377 #endif
6378   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6379   struct fibdef myfib;
6380 #if defined (__DECC) && defined (__VAX)
6381   /* This should be right after the declaration of myatr, but due
6382    * to a bug in VAX DEC C, this takes effect a statement early.
6383    */
6384 #  pragma message restore
6385 #endif
6386   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6387                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6388                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6389
6390   if (file == NULL || *file == '\0') {
6391     set_errno(ENOENT);
6392     set_vaxc_errno(LIB$_INVARG);
6393     return -1;
6394   }
6395   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6396
6397   if (utimes != NULL) {
6398     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
6399      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6400      * Since time_t is unsigned long int, and lib$emul takes a signed long int
6401      * as input, we force the sign bit to be clear by shifting unixtime right
6402      * one bit, then multiplying by an extra factor of 2 in lib$emul().
6403      */
6404     lowbit = (utimes->modtime & 1) ? secscale : 0;
6405     unixtime = (long int) utimes->modtime;
6406 #   ifdef VMSISH_TIME
6407     /* If input was UTC; convert to local for sys svc */
6408     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6409 #   endif
6410     unixtime >>= 1;  secscale <<= 1;
6411     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6412     if (!(retsts & 1)) {
6413       set_errno(EVMSERR);
6414       set_vaxc_errno(retsts);
6415       return -1;
6416     }
6417     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6418     if (!(retsts & 1)) {
6419       set_errno(EVMSERR);
6420       set_vaxc_errno(retsts);
6421       return -1;
6422     }
6423   }
6424   else {
6425     /* Just get the current time in VMS format directly */
6426     retsts = sys$gettim(bintime);
6427     if (!(retsts & 1)) {
6428       set_errno(EVMSERR);
6429       set_vaxc_errno(retsts);
6430       return -1;
6431     }
6432   }
6433
6434   myfab.fab$l_fna = vmsspec;
6435   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6436   myfab.fab$l_nam = &mynam;
6437   mynam.nam$l_esa = esa;
6438   mynam.nam$b_ess = (unsigned char) sizeof esa;
6439   mynam.nam$l_rsa = rsa;
6440   mynam.nam$b_rss = (unsigned char) sizeof rsa;
6441
6442   /* Look for the file to be affected, letting RMS parse the file
6443    * specification for us as well.  I have set errno using only
6444    * values documented in the utime() man page for VMS POSIX.
6445    */
6446   retsts = sys$parse(&myfab,0,0);
6447   if (!(retsts & 1)) {
6448     set_vaxc_errno(retsts);
6449     if      (retsts == RMS$_PRV) set_errno(EACCES);
6450     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6451     else                         set_errno(EVMSERR);
6452     return -1;
6453   }
6454   retsts = sys$search(&myfab,0,0);
6455   if (!(retsts & 1)) {
6456     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6457     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6458     set_vaxc_errno(retsts);
6459     if      (retsts == RMS$_PRV) set_errno(EACCES);
6460     else if (retsts == RMS$_FNF) set_errno(ENOENT);
6461     else                         set_errno(EVMSERR);
6462     return -1;
6463   }
6464
6465   devdsc.dsc$w_length = mynam.nam$b_dev;
6466   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6467
6468   retsts = sys$assign(&devdsc,&chan,0,0);
6469   if (!(retsts & 1)) {
6470     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6471     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6472     set_vaxc_errno(retsts);
6473     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
6474     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
6475     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
6476     else                               set_errno(EVMSERR);
6477     return -1;
6478   }
6479
6480   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6481   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6482
6483   memset((void *) &myfib, 0, sizeof myfib);
6484 #if defined(__DECC) || defined(__DECCXX)
6485   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6486   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6487   /* This prevents the revision time of the file being reset to the current
6488    * time as a result of our IO$_MODIFY $QIO. */
6489   myfib.fib$l_acctl = FIB$M_NORECORD;
6490 #else
6491   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6492   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6493   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6494 #endif
6495   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6496   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6497   myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6498   _ckvmssts(sys$dassgn(chan));
6499   if (retsts & 1) retsts = iosb[0];
6500   if (!(retsts & 1)) {
6501     set_vaxc_errno(retsts);
6502     if (retsts == SS$_NOPRIV) set_errno(EACCES);
6503     else                      set_errno(EVMSERR);
6504     return -1;
6505   }
6506
6507   return 0;
6508 }  /* end of my_utime() */
6509 /*}}}*/
6510
6511 /*
6512  * flex_stat, flex_fstat
6513  * basic stat, but gets it right when asked to stat
6514  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6515  */
6516
6517 /* encode_dev packs a VMS device name string into an integer to allow
6518  * simple comparisons. This can be used, for example, to check whether two
6519  * files are located on the same device, by comparing their encoded device
6520  * names. Even a string comparison would not do, because stat() reuses the
6521  * device name buffer for each call; so without encode_dev, it would be
6522  * necessary to save the buffer and use strcmp (this would mean a number of
6523  * changes to the standard Perl code, to say nothing of what a Perl script
6524  * would have to do.
6525  *
6526  * The device lock id, if it exists, should be unique (unless perhaps compared
6527  * with lock ids transferred from other nodes). We have a lock id if the disk is
6528  * mounted cluster-wide, which is when we tend to get long (host-qualified)
6529  * device names. Thus we use the lock id in preference, and only if that isn't
6530  * available, do we try to pack the device name into an integer (flagged by
6531  * the sign bit (LOCKID_MASK) being set).
6532  *
6533  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6534  * name and its encoded form, but it seems very unlikely that we will find
6535  * two files on different disks that share the same encoded device names,
6536  * and even more remote that they will share the same file id (if the test
6537  * is to check for the same file).
6538  *
6539  * A better method might be to use sys$device_scan on the first call, and to
6540  * search for the device, returning an index into the cached array.
6541  * The number returned would be more intelligable.
6542  * This is probably not worth it, and anyway would take quite a bit longer
6543  * on the first call.
6544  */
6545 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
6546 static mydev_t encode_dev (pTHX_ const char *dev)
6547 {
6548   int i;
6549   unsigned long int f;
6550   mydev_t enc;
6551   char c;
6552   const char *q;
6553
6554   if (!dev || !dev[0]) return 0;
6555
6556 #if LOCKID_MASK
6557   {
6558     struct dsc$descriptor_s dev_desc;
6559     unsigned long int status, lockid, item = DVI$_LOCKID;
6560
6561     /* For cluster-mounted disks, the disk lock identifier is unique, so we
6562        can try that first. */
6563     dev_desc.dsc$w_length =  strlen (dev);
6564     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
6565     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
6566     dev_desc.dsc$a_pointer = (char *) dev;
6567     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6568     if (lockid) return (lockid & ~LOCKID_MASK);
6569   }
6570 #endif
6571
6572   /* Otherwise we try to encode the device name */
6573   enc = 0;
6574   f = 1;
6575   i = 0;
6576   for (q = dev + strlen(dev); q--; q >= dev) {
6577     if (isdigit (*q))
6578       c= (*q) - '0';
6579     else if (isalpha (toupper (*q)))
6580       c= toupper (*q) - 'A' + (char)10;
6581     else
6582       continue; /* Skip '$'s */
6583     i++;
6584     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
6585     if (i>1) f *= 36;
6586     enc += f * (unsigned long int) c;
6587   }
6588   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
6589
6590 }  /* end of encode_dev() */
6591
6592 static char namecache[NAM$C_MAXRSS+1];
6593
6594 static int
6595 is_null_device(name)
6596     const char *name;
6597 {
6598     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6599        The underscore prefix, controller letter, and unit number are
6600        independently optional; for our purposes, the colon punctuation
6601        is not.  The colon can be trailed by optional directory and/or
6602        filename, but two consecutive colons indicates a nodename rather
6603        than a device.  [pr]  */
6604   if (*name == '_') ++name;
6605   if (tolower(*name++) != 'n') return 0;
6606   if (tolower(*name++) != 'l') return 0;
6607   if (tolower(*name) == 'a') ++name;
6608   if (*name == '0') ++name;
6609   return (*name++ == ':') && (*name != ':');
6610 }
6611
6612 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
6613 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6614  * subset of the applicable information.
6615  */
6616 bool
6617 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6618 {
6619   char fname_phdev[NAM$C_MAXRSS+1];
6620   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6621   else {
6622     char fname[NAM$C_MAXRSS+1];
6623     unsigned long int retsts;
6624     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6625                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6626
6627     /* If the struct mystat is stale, we're OOL; stat() overwrites the
6628        device name on successive calls */
6629     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6630     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6631     namdsc.dsc$a_pointer = fname;
6632     namdsc.dsc$w_length = sizeof fname - 1;
6633
6634     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6635                              &namdsc,&namdsc.dsc$w_length,0,0);
6636     if (retsts & 1) {
6637       fname[namdsc.dsc$w_length] = '\0';
6638 /*
6639  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6640  * but if someone has redefined that logical, Perl gets very lost.  Since
6641  * we have the physical device name from the stat buffer, just paste it on.
6642  */
6643       strcpy( fname_phdev, statbufp->st_devnam );
6644       strcat( fname_phdev, strrchr(fname, ':') );
6645
6646       return cando_by_name(bit,effective,fname_phdev);
6647     }
6648     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6649       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6650       return FALSE;
6651     }
6652     _ckvmssts(retsts);
6653     return FALSE;  /* Should never get to here */
6654   }
6655 }  /* end of cando() */
6656 /*}}}*/
6657
6658
6659 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6660 I32
6661 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6662 {
6663   static char usrname[L_cuserid];
6664   static struct dsc$descriptor_s usrdsc =
6665          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6666   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6667   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6668   unsigned short int retlen, trnlnm_iter_count;
6669   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6670   union prvdef curprv;
6671   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6672          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6673   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6674          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6675          {0,0,0,0}};
6676   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6677          {0,0,0,0}};
6678   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6679
6680   if (!fname || !*fname) return FALSE;
6681   /* Make sure we expand logical names, since sys$check_access doesn't */
6682   if (!strpbrk(fname,"/]>:")) {
6683     strcpy(fileified,fname);
6684     trnlnm_iter_count = 0;
6685     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
6686         trnlnm_iter_count++;
6687         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6688     }
6689     fname = fileified;
6690   }
6691   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6692   retlen = namdsc.dsc$w_length = strlen(vmsname);
6693   namdsc.dsc$a_pointer = vmsname;
6694   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6695       vmsname[retlen-1] == ':') {
6696     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6697     namdsc.dsc$w_length = strlen(fileified);
6698     namdsc.dsc$a_pointer = fileified;
6699   }
6700
6701   switch (bit) {
6702     case S_IXUSR: case S_IXGRP: case S_IXOTH:
6703       access = ARM$M_EXECUTE; break;
6704     case S_IRUSR: case S_IRGRP: case S_IROTH:
6705       access = ARM$M_READ; break;
6706     case S_IWUSR: case S_IWGRP: case S_IWOTH:
6707       access = ARM$M_WRITE; break;
6708     case S_IDUSR: case S_IDGRP: case S_IDOTH:
6709       access = ARM$M_DELETE; break;
6710     default:
6711       return FALSE;
6712   }
6713
6714   /* Before we call $check_access, create a user profile with the current
6715    * process privs since otherwise it just uses the default privs from the
6716    * UAF and might give false positives or negatives.  This only works on
6717    * VMS versions v6.0 and later since that's when sys$create_user_profile
6718    * became available.
6719    */
6720
6721   /* get current process privs and username */
6722   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6723   _ckvmssts(iosb[0]);
6724
6725 #if defined(__VMS_VER) && __VMS_VER >= 60000000
6726
6727   /* find out the space required for the profile */
6728   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6729                                     &usrprodsc.dsc$w_length,0));
6730
6731   /* allocate space for the profile and get it filled in */
6732   New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6733   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6734                                     &usrprodsc.dsc$w_length,0));
6735
6736   /* use the profile to check access to the file; free profile & analyze results */
6737   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6738   Safefree(usrprodsc.dsc$a_pointer);
6739   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6740
6741 #else
6742
6743   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6744
6745 #endif
6746
6747   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
6748       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6749       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6750     set_vaxc_errno(retsts);
6751     if (retsts == SS$_NOPRIV) set_errno(EACCES);
6752     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6753     else set_errno(ENOENT);
6754     return FALSE;
6755   }
6756   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6757     return TRUE;
6758   }
6759   _ckvmssts(retsts);
6760
6761   return FALSE;  /* Should never get here */
6762
6763 }  /* end of cando_by_name() */
6764 /*}}}*/
6765
6766
6767 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6768 int
6769 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6770 {
6771   if (!fstat(fd,(stat_t *) statbufp)) {
6772     if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6773     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6774 #   ifdef RTL_USES_UTC
6775 #   ifdef VMSISH_TIME
6776     if (VMSISH_TIME) {
6777       statbufp->st_mtime = _toloc(statbufp->st_mtime);
6778       statbufp->st_atime = _toloc(statbufp->st_atime);
6779       statbufp->st_ctime = _toloc(statbufp->st_ctime);
6780     }
6781 #   endif
6782 #   else
6783 #   ifdef VMSISH_TIME
6784     if (!VMSISH_TIME) { /* Return UTC instead of local time */
6785 #   else
6786     if (1) {
6787 #   endif
6788       statbufp->st_mtime = _toutc(statbufp->st_mtime);
6789       statbufp->st_atime = _toutc(statbufp->st_atime);
6790       statbufp->st_ctime = _toutc(statbufp->st_ctime);
6791     }
6792 #endif
6793     return 0;
6794   }
6795   return -1;
6796
6797 }  /* end of flex_fstat() */
6798 /*}}}*/
6799
6800 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6801 int
6802 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6803 {
6804     char fileified[NAM$C_MAXRSS+1];
6805     char temp_fspec[NAM$C_MAXRSS+300];
6806     int retval = -1;
6807     int saved_errno, saved_vaxc_errno;
6808
6809     if (!fspec) return retval;
6810     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6811     strcpy(temp_fspec, fspec);
6812     if (statbufp == (Stat_t *) &PL_statcache)
6813       do_tovmsspec(temp_fspec,namecache,0);
6814     if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6815       memset(statbufp,0,sizeof *statbufp);
6816       statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6817       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6818       statbufp->st_uid = 0x00010001;
6819       statbufp->st_gid = 0x0001;
6820       time((time_t *)&statbufp->st_mtime);
6821       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6822       return 0;
6823     }
6824
6825     /* Try for a directory name first.  If fspec contains a filename without
6826      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6827      * and sea:[wine.dark]water. exist, we prefer the directory here.
6828      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6829      * not sea:[wine.dark]., if the latter exists.  If the intended target is
6830      * the file with null type, specify this by calling flex_stat() with
6831      * a '.' at the end of fspec.
6832      */
6833     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6834       retval = stat(fileified,(stat_t *) statbufp);
6835       if (!retval && statbufp == (Stat_t *) &PL_statcache)
6836         strcpy(namecache,fileified);
6837     }
6838     if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6839     if (!retval) {
6840       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6841 #     ifdef RTL_USES_UTC
6842 #     ifdef VMSISH_TIME
6843       if (VMSISH_TIME) {
6844         statbufp->st_mtime = _toloc(statbufp->st_mtime);
6845         statbufp->st_atime = _toloc(statbufp->st_atime);
6846         statbufp->st_ctime = _toloc(statbufp->st_ctime);
6847       }
6848 #     endif
6849 #     else
6850 #     ifdef VMSISH_TIME
6851       if (!VMSISH_TIME) { /* Return UTC instead of local time */
6852 #     else
6853       if (1) {
6854 #     endif
6855         statbufp->st_mtime = _toutc(statbufp->st_mtime);
6856         statbufp->st_atime = _toutc(statbufp->st_atime);
6857         statbufp->st_ctime = _toutc(statbufp->st_ctime);
6858       }
6859 #     endif
6860     }
6861     /* If we were successful, leave errno where we found it */
6862     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6863     return retval;
6864
6865 }  /* end of flex_stat() */
6866 /*}}}*/
6867
6868
6869 /*{{{char *my_getlogin()*/
6870 /* VMS cuserid == Unix getlogin, except calling sequence */
6871 char *
6872 my_getlogin()
6873 {
6874     static char user[L_cuserid];
6875     return cuserid(user);
6876 }
6877 /*}}}*/
6878
6879
6880 /*  rmscopy - copy a file using VMS RMS routines
6881  *
6882  *  Copies contents and attributes of spec_in to spec_out, except owner
6883  *  and protection information.  Name and type of spec_in are used as
6884  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
6885  *  should try to propagate timestamps from the input file to the output file.
6886  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
6887  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
6888  *  propagated to the output file at creation iff the output file specification
6889  *  did not contain an explicit name or type, and the revision date is always
6890  *  updated at the end of the copy operation.  If it is greater than 0, then
6891  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6892  *  other than the revision date should be propagated, and bit 1 indicates
6893  *  that the revision date should be propagated.
6894  *
6895  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6896  *
6897  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6898  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
6899  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
6900  * as part of the Perl standard distribution under the terms of the
6901  * GNU General Public License or the Perl Artistic License.  Copies
6902  * of each may be found in the Perl standard distribution.
6903  */
6904 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6905 int
6906 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6907 {
6908     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6909          rsa[NAM$C_MAXRSS], ubf[32256];
6910     unsigned long int i, sts, sts2;
6911     struct FAB fab_in, fab_out;
6912     struct RAB rab_in, rab_out;
6913     struct NAM nam;
6914     struct XABDAT xabdat;
6915     struct XABFHC xabfhc;
6916     struct XABRDT xabrdt;
6917     struct XABSUM xabsum;
6918
6919     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
6920         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6921       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6922       return 0;
6923     }
6924
6925     fab_in = cc$rms_fab;
6926     fab_in.fab$l_fna = vmsin;
6927     fab_in.fab$b_fns = strlen(vmsin);
6928     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6929     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6930     fab_in.fab$l_fop = FAB$M_SQO;
6931     fab_in.fab$l_nam =  &nam;
6932     fab_in.fab$l_xab = (void *) &xabdat;
6933
6934     nam = cc$rms_nam;
6935     nam.nam$l_rsa = rsa;
6936     nam.nam$b_rss = sizeof(rsa);
6937     nam.nam$l_esa = esa;
6938     nam.nam$b_ess = sizeof (esa);
6939     nam.nam$b_esl = nam.nam$b_rsl = 0;
6940
6941     xabdat = cc$rms_xabdat;        /* To get creation date */
6942     xabdat.xab$l_nxt = (void *) &xabfhc;
6943
6944     xabfhc = cc$rms_xabfhc;        /* To get record length */
6945     xabfhc.xab$l_nxt = (void *) &xabsum;
6946
6947     xabsum = cc$rms_xabsum;        /* To get key and area information */
6948
6949     if (!((sts = sys$open(&fab_in)) & 1)) {
6950       set_vaxc_errno(sts);
6951       switch (sts) {
6952         case RMS$_FNF: case RMS$_DNF:
6953           set_errno(ENOENT); break;
6954         case RMS$_DIR:
6955           set_errno(ENOTDIR); break;
6956         case RMS$_DEV:
6957           set_errno(ENODEV); break;
6958         case RMS$_SYN:
6959           set_errno(EINVAL); break;
6960         case RMS$_PRV:
6961           set_errno(EACCES); break;
6962         default:
6963           set_errno(EVMSERR);
6964       }
6965       return 0;
6966     }
6967
6968     fab_out = fab_in;
6969     fab_out.fab$w_ifi = 0;
6970     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6971     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6972     fab_out.fab$l_fop = FAB$M_SQO;
6973     fab_out.fab$l_fna = vmsout;
6974     fab_out.fab$b_fns = strlen(vmsout);
6975     fab_out.fab$l_dna = nam.nam$l_name;
6976     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6977
6978     if (preserve_dates == 0) {  /* Act like DCL COPY */
6979       nam.nam$b_nop = NAM$M_SYNCHK;
6980       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
6981       if (!((sts = sys$parse(&fab_out)) & 1)) {
6982         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6983         set_vaxc_errno(sts);
6984         return 0;
6985       }
6986       fab_out.fab$l_xab = (void *) &xabdat;
6987       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6988     }
6989     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
6990     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
6991       preserve_dates =0;      /* bitmask from this point forward   */
6992
6993     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6994     if (!((sts = sys$create(&fab_out)) & 1)) {
6995       set_vaxc_errno(sts);
6996       switch (sts) {
6997         case RMS$_DNF:
6998           set_errno(ENOENT); break;
6999         case RMS$_DIR:
7000           set_errno(ENOTDIR); break;
7001         case RMS$_DEV:
7002           set_errno(ENODEV); break;
7003         case RMS$_SYN:
7004           set_errno(EINVAL); break;
7005         case RMS$_PRV:
7006           set_errno(EACCES); break;
7007         default:
7008           set_errno(EVMSERR);
7009       }
7010       return 0;
7011     }
7012     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
7013     if (preserve_dates & 2) {
7014       /* sys$close() will process xabrdt, not xabdat */
7015       xabrdt = cc$rms_xabrdt;
7016 #ifndef __GNUC__
7017       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
7018 #else
7019       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
7020        * is unsigned long[2], while DECC & VAXC use a struct */
7021       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
7022 #endif
7023       fab_out.fab$l_xab = (void *) &xabrdt;
7024     }
7025
7026     rab_in = cc$rms_rab;
7027     rab_in.rab$l_fab = &fab_in;
7028     rab_in.rab$l_rop = RAB$M_BIO;
7029     rab_in.rab$l_ubf = ubf;
7030     rab_in.rab$w_usz = sizeof ubf;
7031     if (!((sts = sys$connect(&rab_in)) & 1)) {
7032       sys$close(&fab_in); sys$close(&fab_out);
7033       set_errno(EVMSERR); set_vaxc_errno(sts);
7034       return 0;
7035     }
7036
7037     rab_out = cc$rms_rab;
7038     rab_out.rab$l_fab = &fab_out;
7039     rab_out.rab$l_rbf = ubf;
7040     if (!((sts = sys$connect(&rab_out)) & 1)) {
7041       sys$close(&fab_in); sys$close(&fab_out);
7042       set_errno(EVMSERR); set_vaxc_errno(sts);
7043       return 0;
7044     }
7045
7046     while ((sts = sys$read(&rab_in))) {  /* always true  */
7047       if (sts == RMS$_EOF) break;
7048       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
7049       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
7050         sys$close(&fab_in); sys$close(&fab_out);
7051         set_errno(EVMSERR); set_vaxc_errno(sts);
7052         return 0;
7053       }
7054     }
7055
7056     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
7057     sys$close(&fab_in);  sys$close(&fab_out);
7058     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
7059     if (!(sts & 1)) {
7060       set_errno(EVMSERR); set_vaxc_errno(sts);
7061       return 0;
7062     }
7063
7064     return 1;
7065
7066 }  /* end of rmscopy() */
7067 /*}}}*/
7068
7069
7070 /***  The following glue provides 'hooks' to make some of the routines
7071  * from this file available from Perl.  These routines are sufficiently
7072  * basic, and are required sufficiently early in the build process,
7073  * that's it's nice to have them available to miniperl as well as the
7074  * full Perl, so they're set up here instead of in an extension.  The
7075  * Perl code which handles importation of these names into a given
7076  * package lives in [.VMS]Filespec.pm in @INC.
7077  */
7078
7079 void
7080 rmsexpand_fromperl(pTHX_ CV *cv)
7081 {
7082   dXSARGS;
7083   char *fspec, *defspec = NULL, *rslt;
7084   STRLEN n_a;
7085
7086   if (!items || items > 2)
7087     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
7088   fspec = SvPV(ST(0),n_a);
7089   if (!fspec || !*fspec) XSRETURN_UNDEF;
7090   if (items == 2) defspec = SvPV(ST(1),n_a);
7091
7092   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
7093   ST(0) = sv_newmortal();
7094   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
7095   XSRETURN(1);
7096 }
7097
7098 void
7099 vmsify_fromperl(pTHX_ CV *cv)
7100 {
7101   dXSARGS;
7102   char *vmsified;
7103   STRLEN n_a;
7104
7105   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
7106   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
7107   ST(0) = sv_newmortal();
7108   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7109   XSRETURN(1);
7110 }
7111
7112 void
7113 unixify_fromperl(pTHX_ CV *cv)
7114 {
7115   dXSARGS;
7116   char *unixified;
7117   STRLEN n_a;
7118
7119   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7120   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7121   ST(0) = sv_newmortal();
7122   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7123   XSRETURN(1);
7124 }
7125
7126 void
7127 fileify_fromperl(pTHX_ CV *cv)
7128 {
7129   dXSARGS;
7130   char *fileified;
7131   STRLEN n_a;
7132
7133   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7134   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7135   ST(0) = sv_newmortal();
7136   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7137   XSRETURN(1);
7138 }
7139
7140 void
7141 pathify_fromperl(pTHX_ CV *cv)
7142 {
7143   dXSARGS;
7144   char *pathified;
7145   STRLEN n_a;
7146
7147   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7148   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7149   ST(0) = sv_newmortal();
7150   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7151   XSRETURN(1);
7152 }
7153
7154 void
7155 vmspath_fromperl(pTHX_ CV *cv)
7156 {
7157   dXSARGS;
7158   char *vmspath;
7159   STRLEN n_a;
7160
7161   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7162   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7163   ST(0) = sv_newmortal();
7164   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7165   XSRETURN(1);
7166 }
7167
7168 void
7169 unixpath_fromperl(pTHX_ CV *cv)
7170 {
7171   dXSARGS;
7172   char *unixpath;
7173   STRLEN n_a;
7174
7175   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7176   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7177   ST(0) = sv_newmortal();
7178   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7179   XSRETURN(1);
7180 }
7181
7182 void
7183 candelete_fromperl(pTHX_ CV *cv)
7184 {
7185   dXSARGS;
7186   char fspec[NAM$C_MAXRSS+1], *fsp;
7187   SV *mysv;
7188   IO *io;
7189   STRLEN n_a;
7190
7191   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7192
7193   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7194   if (SvTYPE(mysv) == SVt_PVGV) {
7195     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7196       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7197       ST(0) = &PL_sv_no;
7198       XSRETURN(1);
7199     }
7200     fsp = fspec;
7201   }
7202   else {
7203     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7204       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7205       ST(0) = &PL_sv_no;
7206       XSRETURN(1);
7207     }
7208   }
7209
7210   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7211   XSRETURN(1);
7212 }
7213
7214 void
7215 rmscopy_fromperl(pTHX_ CV *cv)
7216 {
7217   dXSARGS;
7218   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7219   int date_flag;
7220   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7221                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7222   unsigned long int sts;
7223   SV *mysv;
7224   IO *io;
7225   STRLEN n_a;
7226
7227   if (items < 2 || items > 3)
7228     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7229
7230   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7231   if (SvTYPE(mysv) == SVt_PVGV) {
7232     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7233       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7234       ST(0) = &PL_sv_no;
7235       XSRETURN(1);
7236     }
7237     inp = inspec;
7238   }
7239   else {
7240     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7241       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7242       ST(0) = &PL_sv_no;
7243       XSRETURN(1);
7244     }
7245   }
7246   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7247   if (SvTYPE(mysv) == SVt_PVGV) {
7248     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7249       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7250       ST(0) = &PL_sv_no;
7251       XSRETURN(1);
7252     }
7253     outp = outspec;
7254   }
7255   else {
7256     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7257       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7258       ST(0) = &PL_sv_no;
7259       XSRETURN(1);
7260     }
7261   }
7262   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7263
7264   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7265   XSRETURN(1);
7266 }
7267
7268
7269 void
7270 mod2fname(pTHX_ CV *cv)
7271 {
7272   dXSARGS;
7273   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7274        workbuff[NAM$C_MAXRSS*1 + 1];
7275   int total_namelen = 3, counter, num_entries;
7276   /* ODS-5 ups this, but we want to be consistent, so... */
7277   int max_name_len = 39;
7278   AV *in_array = (AV *)SvRV(ST(0));
7279
7280   num_entries = av_len(in_array);
7281
7282   /* All the names start with PL_. */
7283   strcpy(ultimate_name, "PL_");
7284
7285   /* Clean up our working buffer */
7286   Zero(work_name, sizeof(work_name), char);
7287
7288   /* Run through the entries and build up a working name */
7289   for(counter = 0; counter <= num_entries; counter++) {
7290     /* If it's not the first name then tack on a __ */
7291     if (counter) {
7292       strcat(work_name, "__");
7293     }
7294     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7295                            PL_na));
7296   }
7297
7298   /* Check to see if we actually have to bother...*/
7299   if (strlen(work_name) + 3 <= max_name_len) {
7300     strcat(ultimate_name, work_name);
7301   } else {
7302     /* It's too darned big, so we need to go strip. We use the same */
7303     /* algorithm as xsubpp does. First, strip out doubled __ */
7304     char *source, *dest, last;
7305     dest = workbuff;
7306     last = 0;
7307     for (source = work_name; *source; source++) {
7308       if (last == *source && last == '_') {
7309         continue;
7310       }
7311       *dest++ = *source;
7312       last = *source;
7313     }
7314     /* Go put it back */
7315     strcpy(work_name, workbuff);
7316     /* Is it still too big? */
7317     if (strlen(work_name) + 3 > max_name_len) {
7318       /* Strip duplicate letters */
7319       last = 0;
7320       dest = workbuff;
7321       for (source = work_name; *source; source++) {
7322         if (last == toupper(*source)) {
7323         continue;
7324         }
7325         *dest++ = *source;
7326         last = toupper(*source);
7327       }
7328       strcpy(work_name, workbuff);
7329     }
7330
7331     /* Is it *still* too big? */
7332     if (strlen(work_name) + 3 > max_name_len) {
7333       /* Too bad, we truncate */
7334       work_name[max_name_len - 2] = 0;
7335     }
7336     strcat(ultimate_name, work_name);
7337   }
7338
7339   /* Okay, return it */
7340   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7341   XSRETURN(1);
7342 }
7343
7344 void
7345 hushexit_fromperl(pTHX_ CV *cv)
7346 {
7347     dXSARGS;
7348
7349     if (items > 0) {
7350         VMSISH_HUSHED = SvTRUE(ST(0));
7351     }
7352     ST(0) = boolSV(VMSISH_HUSHED);
7353     XSRETURN(1);
7354 }
7355
7356 void
7357 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7358                           struct interp_intern *dst)
7359 {
7360     memcpy(dst,src,sizeof(struct interp_intern));
7361 }
7362
7363 void
7364 Perl_sys_intern_clear(pTHX)
7365 {
7366 }
7367
7368 void
7369 Perl_sys_intern_init(pTHX)
7370 {
7371     unsigned int ix = RAND_MAX;
7372     double x;
7373
7374     VMSISH_HUSHED = 0;
7375
7376     x = (float)ix;
7377     MY_INV_RAND_MAX = 1./x;
7378 }
7379
7380 void
7381 init_os_extras()
7382 {
7383   dTHX;
7384   char* file = __FILE__;
7385   char temp_buff[512];
7386   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7387     no_translate_barewords = TRUE;
7388   } else {
7389     no_translate_barewords = FALSE;
7390   }
7391
7392   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7393   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7394   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7395   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7396   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7397   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7398   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7399   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7400   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7401   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7402   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7403
7404   store_pipelocs(aTHX);         /* will redo any earlier attempts */
7405
7406   return;
7407 }
7408
7409 /*  End of vms.c */