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