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     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
2770       dir[--dirlen] = '\0';
2771       dir[dirlen-1] = '>';
2772     }
2773
2774     if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2775       /* If we've got an explicit filename, we can just shuffle the string. */
2776       if (*(cp1+1)) hasfilename = 1;
2777       /* Similarly, we can just back up a level if we've got multiple levels
2778          of explicit directories in a VMS spec which ends with directories. */
2779       else {
2780         for (cp2 = cp1; cp2 > dir; cp2--) {
2781           if (*cp2 == '.') {
2782             *cp2 = *cp1; *cp1 = '\0';
2783             hasfilename = 1;
2784             break;
2785           }
2786           if (*cp2 == '[' || *cp2 == '<') break;
2787         }
2788       }
2789     }
2790
2791     if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2792       if (dir[0] == '.') {
2793         if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2794           return do_fileify_dirspec("[]",buf,ts);
2795         else if (dir[1] == '.' &&
2796                  (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2797           return do_fileify_dirspec("[-]",buf,ts);
2798       }
2799       if (dirlen && dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
2800         dirlen -= 1;                 /* to last element */
2801         lastdir = strrchr(dir,'/');
2802       }
2803       else if ((cp1 = strstr(dir,"/.")) != NULL) {
2804         /* If we have "/." or "/..", VMSify it and let the VMS code
2805          * below expand it, rather than repeating the code to handle
2806          * relative components of a filespec here */
2807         do {
2808           if (*(cp1+2) == '.') cp1++;
2809           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2810             if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2811             if (strchr(vmsdir,'/') != NULL) {
2812               /* If do_tovmsspec() returned it, it must have VMS syntax
2813                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
2814                * the time to check this here only so we avoid a recursion
2815                * loop; otherwise, gigo.
2816                */
2817               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
2818             }
2819             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2820             return do_tounixspec(trndir,buf,ts);
2821           }
2822           cp1++;
2823         } while ((cp1 = strstr(cp1,"/.")) != NULL);
2824         lastdir = strrchr(dir,'/');
2825       }
2826       else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2827         /* Ditto for specs that end in an MFD -- let the VMS code
2828          * figure out whether it's a real device or a rooted logical. */
2829         dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2830         if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2831         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2832         return do_tounixspec(trndir,buf,ts);
2833       }
2834       else {
2835         if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2836              !(lastdir = cp1 = strrchr(dir,']')) &&
2837              !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2838         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
2839           int ver; char *cp3;
2840           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
2841               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
2842               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2843               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
2844               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2845                             (ver || *cp3)))))) {
2846             set_errno(ENOTDIR);
2847             set_vaxc_errno(RMS$_DIR);
2848             return NULL;
2849           }
2850           dirlen = cp2 - dir;
2851         }
2852       }
2853       /* If we lead off with a device or rooted logical, add the MFD
2854          if we're specifying a top-level directory. */
2855       if (lastdir && *dir == '/') {
2856         addmfd = 1;
2857         for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2858           if (*cp1 == '/') {
2859             addmfd = 0;
2860             break;
2861           }
2862         }
2863       }
2864       retlen = dirlen + (addmfd ? 13 : 6);
2865       if (buf) retspec = buf;
2866       else if (ts) New(1309,retspec,retlen+1,char);
2867       else retspec = __fileify_retbuf;
2868       if (addmfd) {
2869         dirlen = lastdir - dir;
2870         memcpy(retspec,dir,dirlen);
2871         strcpy(&retspec[dirlen],"/000000");
2872         strcpy(&retspec[dirlen+7],lastdir);
2873       }
2874       else {
2875         memcpy(retspec,dir,dirlen);
2876         retspec[dirlen] = '\0';
2877       }
2878       /* We've picked up everything up to the directory file name.
2879          Now just add the type and version, and we're set. */
2880       strcat(retspec,".dir;1");
2881       return retspec;
2882     }
2883     else {  /* VMS-style directory spec */
2884       char esa[NAM$C_MAXRSS+1], term, *cp;
2885       unsigned long int sts, cmplen, haslower = 0;
2886       struct FAB dirfab = cc$rms_fab;
2887       struct NAM savnam, dirnam = cc$rms_nam;
2888
2889       dirfab.fab$b_fns = strlen(dir);
2890       dirfab.fab$l_fna = dir;
2891       dirfab.fab$l_nam = &dirnam;
2892       dirfab.fab$l_dna = ".DIR;1";
2893       dirfab.fab$b_dns = 6;
2894       dirnam.nam$b_ess = NAM$C_MAXRSS;
2895       dirnam.nam$l_esa = esa;
2896
2897       for (cp = dir; *cp; cp++)
2898         if (islower(*cp)) { haslower = 1; break; }
2899       if (!((sts = sys$parse(&dirfab))&1)) {
2900         if (dirfab.fab$l_sts == RMS$_DIR) {
2901           dirnam.nam$b_nop |= NAM$M_SYNCHK;
2902           sts = sys$parse(&dirfab) & 1;
2903         }
2904         if (!sts) {
2905           set_errno(EVMSERR);
2906           set_vaxc_errno(dirfab.fab$l_sts);
2907           return NULL;
2908         }
2909       }
2910       else {
2911         savnam = dirnam;
2912         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
2913           /* Yes; fake the fnb bits so we'll check type below */
2914           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2915         }
2916         else { /* No; just work with potential name */
2917           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2918           else {
2919             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
2920             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2921             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2922             return NULL;
2923           }
2924         }
2925       }
2926       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2927         cp1 = strchr(esa,']');
2928         if (!cp1) cp1 = strchr(esa,'>');
2929         if (cp1) {  /* Should always be true */
2930           dirnam.nam$b_esl -= cp1 - esa - 1;
2931           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2932         }
2933       }
2934       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
2935         /* Yep; check version while we're at it, if it's there. */
2936         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2937         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2938           /* Something other than .DIR[;1].  Bzzt. */
2939           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2940           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2941           set_errno(ENOTDIR);
2942           set_vaxc_errno(RMS$_DIR);
2943           return NULL;
2944         }
2945       }
2946       esa[dirnam.nam$b_esl] = '\0';
2947       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2948         /* They provided at least the name; we added the type, if necessary, */
2949         if (buf) retspec = buf;                            /* in sys$parse() */
2950         else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2951         else retspec = __fileify_retbuf;
2952         strcpy(retspec,esa);
2953         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2954         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2955         return retspec;
2956       }
2957       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2958         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2959         *cp1 = '\0';
2960         dirnam.nam$b_esl -= 9;
2961       }
2962       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2963       if (cp1 == NULL) { /* should never happen */
2964         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2965         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2966         return NULL;
2967       }
2968       term = *cp1;
2969       *cp1 = '\0';
2970       retlen = strlen(esa);
2971       if ((cp1 = strrchr(esa,'.')) != NULL) {
2972         /* There's more than one directory in the path.  Just roll back. */
2973         *cp1 = term;
2974         if (buf) retspec = buf;
2975         else if (ts) New(1311,retspec,retlen+7,char);
2976         else retspec = __fileify_retbuf;
2977         strcpy(retspec,esa);
2978       }
2979       else {
2980         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2981           /* Go back and expand rooted logical name */
2982           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2983           if (!(sys$parse(&dirfab) & 1)) {
2984             dirnam.nam$l_rlf = NULL;
2985             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2986             set_errno(EVMSERR);
2987             set_vaxc_errno(dirfab.fab$l_sts);
2988             return NULL;
2989           }
2990           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2991           if (buf) retspec = buf;
2992           else if (ts) New(1312,retspec,retlen+16,char);
2993           else retspec = __fileify_retbuf;
2994           cp1 = strstr(esa,"][");
2995           if (!cp1) cp1 = strstr(esa,"]<");
2996           dirlen = cp1 - esa;
2997           memcpy(retspec,esa,dirlen);
2998           if (!strncmp(cp1+2,"000000]",7)) {
2999             retspec[dirlen-1] = '\0';
3000             for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3001             if (*cp1 == '.') *cp1 = ']';
3002             else {
3003               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3004               memcpy(cp1+1,"000000]",7);
3005             }
3006           }
3007           else {
3008             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3009             retspec[retlen] = '\0';
3010             /* Convert last '.' to ']' */
3011             for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3012             if (*cp1 == '.') *cp1 = ']';
3013             else {
3014               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3015               memcpy(cp1+1,"000000]",7);
3016             }
3017           }
3018         }
3019         else {  /* This is a top-level dir.  Add the MFD to the path. */
3020           if (buf) retspec = buf;
3021           else if (ts) New(1312,retspec,retlen+16,char);
3022           else retspec = __fileify_retbuf;
3023           cp1 = esa;
3024           cp2 = retspec;
3025           while (*cp1 != ':') *(cp2++) = *(cp1++);
3026           strcpy(cp2,":[000000]");
3027           cp1 += 2;
3028           strcpy(cp2+9,cp1);
3029         }
3030       }
3031       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3032       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3033       /* We've set up the string up through the filename.  Add the
3034          type and version, and we're done. */
3035       strcat(retspec,".DIR;1");
3036
3037       /* $PARSE may have upcased filespec, so convert output to lower
3038        * case if input contained any lowercase characters. */
3039       if (haslower) __mystrtolower(retspec);
3040       return retspec;
3041     }
3042 }  /* end of do_fileify_dirspec() */
3043 /*}}}*/
3044 /* External entry points */
3045 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3046 { return do_fileify_dirspec(dir,buf,0); }
3047 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3048 { return do_fileify_dirspec(dir,buf,1); }
3049
3050 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3051 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3052 {
3053     static char __pathify_retbuf[NAM$C_MAXRSS+1];
3054     unsigned long int retlen;
3055     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3056
3057     if (!dir || !*dir) {
3058       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3059     }
3060
3061     if (*dir) strcpy(trndir,dir);
3062     else getcwd(trndir,sizeof trndir - 1);
3063
3064     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3065            && my_trnlnm(trndir,trndir,0)) {
3066       STRLEN trnlen = strlen(trndir);
3067
3068       /* Trap simple rooted lnms, and return lnm:[000000] */
3069       if (!strcmp(trndir+trnlen-2,".]")) {
3070         if (buf) retpath = buf;
3071         else if (ts) New(1318,retpath,strlen(dir)+10,char);
3072         else retpath = __pathify_retbuf;
3073         strcpy(retpath,dir);
3074         strcat(retpath,":[000000]");
3075         return retpath;
3076       }
3077     }
3078     dir = trndir;
3079
3080     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3081       if (*dir == '.' && (*(dir+1) == '\0' ||
3082                           (*(dir+1) == '.' && *(dir+2) == '\0')))
3083         retlen = 2 + (*(dir+1) != '\0');
3084       else {
3085         if ( !(cp1 = strrchr(dir,'/')) &&
3086              !(cp1 = strrchr(dir,']')) &&
3087              !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3088         if ((cp2 = strchr(cp1,'.')) != NULL &&
3089             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
3090              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
3091               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3092               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3093           int ver; char *cp3;
3094           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3095               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3096               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3097               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3098               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3099                             (ver || *cp3)))))) {
3100             set_errno(ENOTDIR);
3101             set_vaxc_errno(RMS$_DIR);
3102             return NULL;
3103           }
3104           retlen = cp2 - dir + 1;
3105         }
3106         else {  /* No file type present.  Treat the filename as a directory. */
3107           retlen = strlen(dir) + 1;
3108         }
3109       }
3110       if (buf) retpath = buf;
3111       else if (ts) New(1313,retpath,retlen+1,char);
3112       else retpath = __pathify_retbuf;
3113       strncpy(retpath,dir,retlen-1);
3114       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3115         retpath[retlen-1] = '/';      /* with '/', add it. */
3116         retpath[retlen] = '\0';
3117       }
3118       else retpath[retlen-1] = '\0';
3119     }
3120     else {  /* VMS-style directory spec */
3121       char esa[NAM$C_MAXRSS+1], *cp;
3122       unsigned long int sts, cmplen, haslower;
3123       struct FAB dirfab = cc$rms_fab;
3124       struct NAM savnam, dirnam = cc$rms_nam;
3125
3126       /* If we've got an explicit filename, we can just shuffle the string. */
3127       if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3128              (cp1 = strrchr(dir,'>')) != NULL     ) && *(cp1+1)) {
3129         if ((cp2 = strchr(cp1,'.')) != NULL) {
3130           int ver; char *cp3;
3131           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
3132               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
3133               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3134               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
3135               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3136                             (ver || *cp3)))))) {
3137             set_errno(ENOTDIR);
3138             set_vaxc_errno(RMS$_DIR);
3139             return NULL;
3140           }
3141         }
3142         else {  /* No file type, so just draw name into directory part */
3143           for (cp2 = cp1; *cp2; cp2++) ;
3144         }
3145         *cp2 = *cp1;
3146         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
3147         *cp1 = '.';
3148         /* We've now got a VMS 'path'; fall through */
3149       }
3150       dirfab.fab$b_fns = strlen(dir);
3151       dirfab.fab$l_fna = dir;
3152       if (dir[dirfab.fab$b_fns-1] == ']' ||
3153           dir[dirfab.fab$b_fns-1] == '>' ||
3154           dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3155         if (buf) retpath = buf;
3156         else if (ts) New(1314,retpath,strlen(dir)+1,char);
3157         else retpath = __pathify_retbuf;
3158         strcpy(retpath,dir);
3159         return retpath;
3160       }
3161       dirfab.fab$l_dna = ".DIR;1";
3162       dirfab.fab$b_dns = 6;
3163       dirfab.fab$l_nam = &dirnam;
3164       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3165       dirnam.nam$l_esa = esa;
3166
3167       for (cp = dir; *cp; cp++)
3168         if (islower(*cp)) { haslower = 1; break; }
3169
3170       if (!(sts = (sys$parse(&dirfab)&1))) {
3171         if (dirfab.fab$l_sts == RMS$_DIR) {
3172           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3173           sts = sys$parse(&dirfab) & 1;
3174         }
3175         if (!sts) {
3176           set_errno(EVMSERR);
3177           set_vaxc_errno(dirfab.fab$l_sts);
3178           return NULL;
3179         }
3180       }
3181       else {
3182         savnam = dirnam;
3183         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
3184           if (dirfab.fab$l_sts != RMS$_FNF) {
3185             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3186             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3187             set_errno(EVMSERR);
3188             set_vaxc_errno(dirfab.fab$l_sts);
3189             return NULL;
3190           }
3191           dirnam = savnam; /* No; just work with potential name */
3192         }
3193       }
3194       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3195         /* Yep; check version while we're at it, if it's there. */
3196         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3197         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3198           /* Something other than .DIR[;1].  Bzzt. */
3199           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3200           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3201           set_errno(ENOTDIR);
3202           set_vaxc_errno(RMS$_DIR);
3203           return NULL;
3204         }
3205       }
3206       /* OK, the type was fine.  Now pull any file name into the
3207          directory path. */
3208       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3209       else {
3210         cp1 = strrchr(esa,'>');
3211         *dirnam.nam$l_type = '>';
3212       }
3213       *cp1 = '.';
3214       *(dirnam.nam$l_type + 1) = '\0';
3215       retlen = dirnam.nam$l_type - esa + 2;
3216       if (buf) retpath = buf;
3217       else if (ts) New(1314,retpath,retlen,char);
3218       else retpath = __pathify_retbuf;
3219       strcpy(retpath,esa);
3220       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3221       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3222       /* $PARSE may have upcased filespec, so convert output to lower
3223        * case if input contained any lowercase characters. */
3224       if (haslower) __mystrtolower(retpath);
3225     }
3226
3227     return retpath;
3228 }  /* end of do_pathify_dirspec() */
3229 /*}}}*/
3230 /* External entry points */
3231 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3232 { return do_pathify_dirspec(dir,buf,0); }
3233 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3234 { return do_pathify_dirspec(dir,buf,1); }
3235
3236 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3237 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3238 {
3239   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3240   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3241   int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3242
3243   if (spec == NULL) return NULL;
3244   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3245   if (buf) rslt = buf;
3246   else if (ts) {
3247     retlen = strlen(spec);
3248     cp1 = strchr(spec,'[');
3249     if (!cp1) cp1 = strchr(spec,'<');
3250     if (cp1) {
3251       for (cp1++; *cp1; cp1++) {
3252         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
3253         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3254           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3255       }
3256     }
3257     New(1315,rslt,retlen+2+2*expand,char);
3258   }
3259   else rslt = __tounixspec_retbuf;
3260   if (strchr(spec,'/') != NULL) {
3261     strcpy(rslt,spec);
3262     return rslt;
3263   }
3264
3265   cp1 = rslt;
3266   cp2 = spec;
3267   dirend = strrchr(spec,']');
3268   if (dirend == NULL) dirend = strrchr(spec,'>');
3269   if (dirend == NULL) dirend = strchr(spec,':');
3270   if (dirend == NULL) {
3271     strcpy(rslt,spec);
3272     return rslt;
3273   }
3274   if (*cp2 != '[' && *cp2 != '<') {
3275     *(cp1++) = '/';
3276   }
3277   else {  /* the VMS spec begins with directories */
3278     cp2++;
3279     if (*cp2 == ']' || *cp2 == '>') {
3280       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3281       return rslt;
3282     }
3283     else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3284       if (getcwd(tmp,sizeof tmp,1) == NULL) {
3285         if (ts) Safefree(rslt);
3286         return NULL;
3287       }
3288       do {
3289         cp3 = tmp;
3290         while (*cp3 != ':' && *cp3) cp3++;
3291         *(cp3++) = '\0';
3292         if (strchr(cp3,']') != NULL) break;
3293       } while (vmstrnenv(tmp,tmp,0,fildev,0));
3294       if (ts && !buf &&
3295           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3296         retlen = devlen + dirlen;
3297         Renew(rslt,retlen+1+2*expand,char);
3298         cp1 = rslt;
3299       }
3300       cp3 = tmp;
3301       *(cp1++) = '/';
3302       while (*cp3) {
3303         *(cp1++) = *(cp3++);
3304         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3305       }
3306       *(cp1++) = '/';
3307     }
3308     else if ( *cp2 == '.') {
3309       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3310         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3311         cp2 += 3;
3312       }
3313       else cp2++;
3314     }
3315   }
3316   for (; cp2 <= dirend; cp2++) {
3317     if (*cp2 == ':') {
3318       *(cp1++) = '/';
3319       if (*(cp2+1) == '[') cp2++;
3320     }
3321     else if (*cp2 == ']' || *cp2 == '>') {
3322       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3323     }
3324     else if (*cp2 == '.') {
3325       *(cp1++) = '/';
3326       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3327         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3328                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3329         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3330             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3331       }
3332       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3333         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3334         cp2 += 2;
3335       }
3336     }
3337     else if (*cp2 == '-') {
3338       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3339         while (*cp2 == '-') {
3340           cp2++;
3341           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3342         }
3343         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3344           if (ts) Safefree(rslt);                        /* filespecs like */
3345           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
3346           return NULL;
3347         }
3348       }
3349       else *(cp1++) = *cp2;
3350     }
3351     else *(cp1++) = *cp2;
3352   }
3353   while (*cp2) *(cp1++) = *(cp2++);
3354   *cp1 = '\0';
3355
3356   return rslt;
3357
3358 }  /* end of do_tounixspec() */
3359 /*}}}*/
3360 /* External entry points */
3361 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3362 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3363
3364 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3365 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3366   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3367   char *rslt, *dirend;
3368   register char *cp1, *cp2;
3369   unsigned long int infront = 0, hasdir = 1;
3370
3371   if (path == NULL) return NULL;
3372   if (buf) rslt = buf;
3373   else if (ts) New(1316,rslt,strlen(path)+9,char);
3374   else rslt = __tovmsspec_retbuf;
3375   if (strpbrk(path,"]:>") ||
3376       (dirend = strrchr(path,'/')) == NULL) {
3377     if (path[0] == '.') {
3378       if (path[1] == '\0') strcpy(rslt,"[]");
3379       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3380       else strcpy(rslt,path); /* probably garbage */
3381     }
3382     else strcpy(rslt,path);
3383     return rslt;
3384   }
3385   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
3386     if (!*(dirend+2)) dirend +=2;
3387     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3388     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3389   }
3390   cp1 = rslt;
3391   cp2 = path;
3392   if (*cp2 == '/') {
3393     char trndev[NAM$C_MAXRSS+1];
3394     int islnm, rooted;
3395     STRLEN trnend;
3396
3397     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
3398     if (!*(cp2+1)) {
3399       if (!buf & ts) Renew(rslt,18,char);
3400       strcpy(rslt,"sys$disk:[000000]");
3401       return rslt;
3402     }
3403     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3404     *cp1 = '\0';
3405     islnm =  my_trnlnm(rslt,trndev,0);
3406     trnend = islnm ? strlen(trndev) - 1 : 0;
3407     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3408     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3409     /* If the first element of the path is a logical name, determine
3410      * whether it has to be translated so we can add more directories. */
3411     if (!islnm || rooted) {
3412       *(cp1++) = ':';
3413       *(cp1++) = '[';
3414       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3415       else cp2++;
3416     }
3417     else {
3418       if (cp2 != dirend) {
3419         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3420         strcpy(rslt,trndev);
3421         cp1 = rslt + trnend;
3422         *(cp1++) = '.';
3423         cp2++;
3424       }
3425       else {
3426         *(cp1++) = ':';
3427         hasdir = 0;
3428       }
3429     }
3430   }
3431   else {
3432     *(cp1++) = '[';
3433     if (*cp2 == '.') {
3434       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3435         cp2 += 2;         /* skip over "./" - it's redundant */
3436         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
3437       }
3438       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3439         *(cp1++) = '-';                                 /* "../" --> "-" */
3440         cp2 += 3;
3441       }
3442       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3443                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3444         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3445         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3446         cp2 += 4;
3447       }
3448       if (cp2 > dirend) cp2 = dirend;
3449     }
3450     else *(cp1++) = '.';
3451   }
3452   for (; cp2 < dirend; cp2++) {
3453     if (*cp2 == '/') {
3454       if (*(cp2-1) == '/') continue;
3455       if (*(cp1-1) != '.') *(cp1++) = '.';
3456       infront = 0;
3457     }
3458     else if (!infront && *cp2 == '.') {
3459       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3460       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
3461       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3462         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3463         else if (*(cp1-2) == '[') *(cp1-1) = '-';
3464         else {  /* back up over previous directory name */
3465           cp1--;
3466           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3467           if (*(cp1-1) == '[') {
3468             memcpy(cp1,"000000.",7);
3469             cp1 += 7;
3470           }
3471         }
3472         cp2 += 2;
3473         if (cp2 == dirend) break;
3474       }
3475       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3476                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3477         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3478         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3479         if (!*(cp2+3)) {
3480           *(cp1++) = '.';  /* Simulate trailing '/' */
3481           cp2 += 2;  /* for loop will incr this to == dirend */
3482         }
3483         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
3484       }
3485       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
3486     }
3487     else {
3488       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
3489       if (*cp2 == '.')      *(cp1++) = '_';
3490       else                  *(cp1++) =  *cp2;
3491       infront = 1;
3492     }
3493   }
3494   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3495   if (hasdir) *(cp1++) = ']';
3496   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
3497   while (*cp2) *(cp1++) = *(cp2++);
3498   *cp1 = '\0';
3499
3500   return rslt;
3501
3502 }  /* end of do_tovmsspec() */
3503 /*}}}*/
3504 /* External entry points */
3505 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3506 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3507
3508 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3509 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3510   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3511   int vmslen;
3512   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3513
3514   if (path == NULL) return NULL;
3515   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3516   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3517   if (buf) return buf;
3518   else if (ts) {
3519     vmslen = strlen(vmsified);
3520     New(1317,cp,vmslen+1,char);
3521     memcpy(cp,vmsified,vmslen);
3522     cp[vmslen] = '\0';
3523     return cp;
3524   }
3525   else {
3526     strcpy(__tovmspath_retbuf,vmsified);
3527     return __tovmspath_retbuf;
3528   }
3529
3530 }  /* end of do_tovmspath() */
3531 /*}}}*/
3532 /* External entry points */
3533 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3534 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3535
3536
3537 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3538 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3539   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3540   int unixlen;
3541   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3542
3543   if (path == NULL) return NULL;
3544   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3545   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3546   if (buf) return buf;
3547   else if (ts) {
3548     unixlen = strlen(unixified);
3549     New(1317,cp,unixlen+1,char);
3550     memcpy(cp,unixified,unixlen);
3551     cp[unixlen] = '\0';
3552     return cp;
3553   }
3554   else {
3555     strcpy(__tounixpath_retbuf,unixified);
3556     return __tounixpath_retbuf;
3557   }
3558
3559 }  /* end of do_tounixpath() */
3560 /*}}}*/
3561 /* External entry points */
3562 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3563 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3564
3565 /*
3566  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
3567  *
3568  *****************************************************************************
3569  *                                                                           *
3570  *  Copyright (C) 1989-1994 by                                               *
3571  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
3572  *                                                                           *
3573  *  Permission is hereby  granted for the reproduction of this software,     *
3574  *  on condition that this copyright notice is included in the reproduction, *
3575  *  and that such reproduction is not for purposes of profit or material     *
3576  *  gain.                                                                    *
3577  *                                                                           *
3578  *  27-Aug-1994 Modified for inclusion in perl5                              *
3579  *              by Charles Bailey  bailey@newman.upenn.edu                   *
3580  *****************************************************************************
3581  */
3582
3583 /*
3584  * getredirection() is intended to aid in porting C programs
3585  * to VMS (Vax-11 C).  The native VMS environment does not support
3586  * '>' and '<' I/O redirection, or command line wild card expansion,
3587  * or a command line pipe mechanism using the '|' AND background
3588  * command execution '&'.  All of these capabilities are provided to any
3589  * C program which calls this procedure as the first thing in the
3590  * main program.
3591  * The piping mechanism will probably work with almost any 'filter' type
3592  * of program.  With suitable modification, it may useful for other
3593  * portability problems as well.
3594  *
3595  * Author:  Mark Pizzolato      mark@infocomm.com
3596  */
3597 struct list_item
3598     {
3599     struct list_item *next;
3600     char *value;
3601     };
3602
3603 static void add_item(struct list_item **head,
3604                      struct list_item **tail,
3605                      char *value,
3606                      int *count);
3607
3608 static void mp_expand_wild_cards(pTHX_ char *item,
3609                                 struct list_item **head,
3610                                 struct list_item **tail,
3611                                 int *count);
3612
3613 static int background_process(int argc, char **argv);
3614
3615 static void pipe_and_fork(pTHX_ char **cmargv);
3616
3617 /*{{{ void getredirection(int *ac, char ***av)*/
3618 static void
3619 mp_getredirection(pTHX_ int *ac, char ***av)
3620 /*
3621  * Process vms redirection arg's.  Exit if any error is seen.
3622  * If getredirection() processes an argument, it is erased
3623  * from the vector.  getredirection() returns a new argc and argv value.
3624  * In the event that a background command is requested (by a trailing "&"),
3625  * this routine creates a background subprocess, and simply exits the program.
3626  *
3627  * Warning: do not try to simplify the code for vms.  The code
3628  * presupposes that getredirection() is called before any data is
3629  * read from stdin or written to stdout.
3630  *
3631  * Normal usage is as follows:
3632  *
3633  *      main(argc, argv)
3634  *      int             argc;
3635  *      char            *argv[];
3636  *      {
3637  *              getredirection(&argc, &argv);
3638  *      }
3639  */
3640 {
3641     int                 argc = *ac;     /* Argument Count         */
3642     char                **argv = *av;   /* Argument Vector        */
3643     char                *ap;            /* Argument pointer       */
3644     int                 j;              /* argv[] index           */
3645     int                 item_count = 0; /* Count of Items in List */
3646     struct list_item    *list_head = 0; /* First Item in List       */
3647     struct list_item    *list_tail;     /* Last Item in List        */
3648     char                *in = NULL;     /* Input File Name          */
3649     char                *out = NULL;    /* Output File Name         */
3650     char                *outmode = "w"; /* Mode to Open Output File */
3651     char                *err = NULL;    /* Error File Name          */
3652     char                *errmode = "w"; /* Mode to Open Error File  */
3653     int                 cmargc = 0;     /* Piped Command Arg Count  */
3654     char                **cmargv = NULL;/* Piped Command Arg Vector */
3655
3656     /*
3657      * First handle the case where the last thing on the line ends with
3658      * a '&'.  This indicates the desire for the command to be run in a
3659      * subprocess, so we satisfy that desire.
3660      */
3661     ap = argv[argc-1];
3662     if (0 == strcmp("&", ap))
3663         exit(background_process(--argc, argv));
3664     if (*ap && '&' == ap[strlen(ap)-1])
3665         {
3666         ap[strlen(ap)-1] = '\0';
3667         exit(background_process(argc, argv));
3668         }
3669     /*
3670      * Now we handle the general redirection cases that involve '>', '>>',
3671      * '<', and pipes '|'.
3672      */
3673     for (j = 0; j < argc; ++j)
3674         {
3675         if (0 == strcmp("<", argv[j]))
3676             {
3677             if (j+1 >= argc)
3678                 {
3679                 fprintf(stderr,"No input file after < on command line");
3680                 exit(LIB$_WRONUMARG);
3681                 }
3682             in = argv[++j];
3683             continue;
3684             }
3685         if ('<' == *(ap = argv[j]))
3686             {
3687             in = 1 + ap;
3688             continue;
3689             }
3690         if (0 == strcmp(">", ap))
3691             {
3692             if (j+1 >= argc)
3693                 {
3694                 fprintf(stderr,"No output file after > on command line");
3695                 exit(LIB$_WRONUMARG);
3696                 }
3697             out = argv[++j];
3698             continue;
3699             }
3700         if ('>' == *ap)
3701             {
3702             if ('>' == ap[1])
3703                 {
3704                 outmode = "a";
3705                 if ('\0' == ap[2])
3706                     out = argv[++j];
3707                 else
3708                     out = 2 + ap;
3709                 }
3710             else
3711                 out = 1 + ap;
3712             if (j >= argc)
3713                 {
3714                 fprintf(stderr,"No output file after > or >> on command line");
3715                 exit(LIB$_WRONUMARG);
3716                 }
3717             continue;
3718             }
3719         if (('2' == *ap) && ('>' == ap[1]))
3720             {
3721             if ('>' == ap[2])
3722                 {
3723                 errmode = "a";
3724                 if ('\0' == ap[3])
3725                     err = argv[++j];
3726                 else
3727                     err = 3 + ap;
3728                 }
3729             else
3730                 if ('\0' == ap[2])
3731                     err = argv[++j];
3732                 else
3733                     err = 2 + ap;
3734             if (j >= argc)
3735                 {
3736                 fprintf(stderr,"No output file after 2> or 2>> on command line");
3737                 exit(LIB$_WRONUMARG);
3738                 }
3739             continue;
3740             }
3741         if (0 == strcmp("|", argv[j]))
3742             {
3743             if (j+1 >= argc)
3744                 {
3745                 fprintf(stderr,"No command into which to pipe on command line");
3746                 exit(LIB$_WRONUMARG);
3747                 }
3748             cmargc = argc-(j+1);
3749             cmargv = &argv[j+1];
3750             argc = j;
3751             continue;
3752             }
3753         if ('|' == *(ap = argv[j]))
3754             {
3755             ++argv[j];
3756             cmargc = argc-j;
3757             cmargv = &argv[j];
3758             argc = j;
3759             continue;
3760             }
3761         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3762         }
3763     /*
3764      * Allocate and fill in the new argument vector, Some Unix's terminate
3765      * the list with an extra null pointer.
3766      */
3767     New(1302, argv, item_count+1, char *);
3768     *av = argv;
3769     for (j = 0; j < item_count; ++j, list_head = list_head->next)
3770         argv[j] = list_head->value;
3771     *ac = item_count;
3772     if (cmargv != NULL)
3773         {
3774         if (out != NULL)
3775             {
3776             fprintf(stderr,"'|' and '>' may not both be specified on command line");
3777             exit(LIB$_INVARGORD);
3778             }
3779         pipe_and_fork(aTHX_ cmargv);
3780         }
3781
3782     /* Check for input from a pipe (mailbox) */
3783
3784     if (in == NULL && 1 == isapipe(0))
3785         {
3786         char mbxname[L_tmpnam];
3787         long int bufsize;
3788         long int dvi_item = DVI$_DEVBUFSIZ;
3789         $DESCRIPTOR(mbxnam, "");
3790         $DESCRIPTOR(mbxdevnam, "");
3791
3792         /* Input from a pipe, reopen it in binary mode to disable       */
3793         /* carriage control processing.                                 */
3794
3795         fgetname(stdin, mbxname);
3796         mbxnam.dsc$a_pointer = mbxname;
3797         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3798         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3799         mbxdevnam.dsc$a_pointer = mbxname;
3800         mbxdevnam.dsc$w_length = sizeof(mbxname);
3801         dvi_item = DVI$_DEVNAM;
3802         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3803         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3804         set_errno(0);
3805         set_vaxc_errno(1);
3806         freopen(mbxname, "rb", stdin);
3807         if (errno != 0)
3808             {
3809             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3810             exit(vaxc$errno);
3811             }
3812         }
3813     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3814         {
3815         fprintf(stderr,"Can't open input file %s as stdin",in);
3816         exit(vaxc$errno);
3817         }
3818     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3819         {
3820         fprintf(stderr,"Can't open output file %s as stdout",out);
3821         exit(vaxc$errno);
3822         }
3823         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
3824
3825     if (err != NULL) {
3826         if (strcmp(err,"&1") == 0) {
3827             dup2(fileno(stdout), fileno(stderr));
3828             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
3829         } else {
3830         FILE *tmperr;
3831         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3832             {
3833             fprintf(stderr,"Can't open error file %s as stderr",err);
3834             exit(vaxc$errno);
3835             }
3836             fclose(tmperr);
3837            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
3838                 {
3839                 exit(vaxc$errno);
3840                 }
3841             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
3842         }
3843         }
3844 #ifdef ARGPROC_DEBUG
3845     PerlIO_printf(Perl_debug_log, "Arglist:\n");
3846     for (j = 0; j < *ac;  ++j)
3847         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3848 #endif
3849    /* Clear errors we may have hit expanding wildcards, so they don't
3850       show up in Perl's $! later */
3851    set_errno(0); set_vaxc_errno(1);
3852 }  /* end of getredirection() */
3853 /*}}}*/
3854
3855 static void add_item(struct list_item **head,
3856                      struct list_item **tail,
3857                      char *value,
3858                      int *count)
3859 {
3860     if (*head == 0)
3861         {
3862         New(1303,*head,1,struct list_item);
3863         *tail = *head;
3864         }
3865     else {
3866         New(1304,(*tail)->next,1,struct list_item);
3867         *tail = (*tail)->next;
3868         }
3869     (*tail)->value = value;
3870     ++(*count);
3871 }
3872
3873 static void mp_expand_wild_cards(pTHX_ char *item,
3874                               struct list_item **head,
3875                               struct list_item **tail,
3876                               int *count)
3877 {
3878 int expcount = 0;
3879 unsigned long int context = 0;
3880 int isunix = 0;
3881 char *had_version;
3882 char *had_device;
3883 int had_directory;
3884 char *devdir,*cp;
3885 char vmsspec[NAM$C_MAXRSS+1];
3886 $DESCRIPTOR(filespec, "");
3887 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3888 $DESCRIPTOR(resultspec, "");
3889 unsigned long int zero = 0, sts;
3890
3891     for (cp = item; *cp; cp++) {
3892         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3893         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3894     }
3895     if (!*cp || isspace(*cp))
3896         {
3897         add_item(head, tail, item, count);
3898         return;
3899         }
3900     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3901     resultspec.dsc$b_class = DSC$K_CLASS_D;
3902     resultspec.dsc$a_pointer = NULL;
3903     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3904       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3905     if (!isunix || !filespec.dsc$a_pointer)
3906       filespec.dsc$a_pointer = item;
3907     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3908     /*
3909      * Only return version specs, if the caller specified a version
3910      */
3911     had_version = strchr(item, ';');
3912     /*
3913      * Only return device and directory specs, if the caller specifed either.
3914      */
3915     had_device = strchr(item, ':');
3916     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3917
3918     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3919                                   &defaultspec, 0, 0, &zero))))
3920         {
3921         char *string;
3922         char *c;
3923
3924         New(1305,string,resultspec.dsc$w_length+1,char);
3925         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3926         string[resultspec.dsc$w_length] = '\0';
3927         if (NULL == had_version)
3928             *((char *)strrchr(string, ';')) = '\0';
3929         if ((!had_directory) && (had_device == NULL))
3930             {
3931             if (NULL == (devdir = strrchr(string, ']')))
3932                 devdir = strrchr(string, '>');
3933             strcpy(string, devdir + 1);
3934             }
3935         /*
3936          * Be consistent with what the C RTL has already done to the rest of
3937          * the argv items and lowercase all of these names.
3938          */
3939         for (c = string; *c; ++c)
3940             if (isupper(*c))
3941                 *c = tolower(*c);
3942         if (isunix) trim_unixpath(string,item,1);
3943         add_item(head, tail, string, count);
3944         ++expcount;
3945         }
3946     if (sts != RMS$_NMF)
3947         {
3948         set_vaxc_errno(sts);
3949         switch (sts)
3950             {
3951             case RMS$_FNF: case RMS$_DNF:
3952                 set_errno(ENOENT); break;
3953             case RMS$_DIR:
3954                 set_errno(ENOTDIR); break;
3955             case RMS$_DEV:
3956                 set_errno(ENODEV); break;
3957             case RMS$_FNM: case RMS$_SYN:
3958                 set_errno(EINVAL); break;
3959             case RMS$_PRV:
3960                 set_errno(EACCES); break;
3961             default:
3962                 _ckvmssts_noperl(sts);
3963             }
3964         }
3965     if (expcount == 0)
3966         add_item(head, tail, item, count);
3967     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3968     _ckvmssts_noperl(lib$find_file_end(&context));
3969 }
3970
3971 static int child_st[2];/* Event Flag set when child process completes   */
3972
3973 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
3974
3975 static unsigned long int exit_handler(int *status)
3976 {
3977 short iosb[4];
3978
3979     if (0 == child_st[0])
3980         {
3981 #ifdef ARGPROC_DEBUG
3982         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3983 #endif
3984         fflush(stdout);     /* Have to flush pipe for binary data to    */
3985                             /* terminate properly -- <tp@mccall.com>    */
3986         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3987         sys$dassgn(child_chan);
3988         fclose(stdout);
3989         sys$synch(0, child_st);
3990         }
3991     return(1);
3992 }
3993
3994 static void sig_child(int chan)
3995 {
3996 #ifdef ARGPROC_DEBUG
3997     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
3998 #endif
3999     if (child_st[0] == 0)
4000         child_st[0] = 1;
4001 }
4002
4003 static struct exit_control_block exit_block =
4004     {
4005     0,
4006     exit_handler,
4007     1,
4008     &exit_block.exit_status,
4009     0
4010     };
4011
4012 static void pipe_and_fork(pTHX_ char **cmargv)
4013 {
4014     char subcmd[2048];
4015     $DESCRIPTOR(cmddsc, "");
4016     static char mbxname[64];
4017     $DESCRIPTOR(mbxdsc, mbxname);
4018     int pid, j;
4019     unsigned long int zero = 0, one = 1;
4020
4021     strcpy(subcmd, cmargv[0]);
4022     for (j = 1; NULL != cmargv[j]; ++j)
4023         {
4024         strcat(subcmd, " \"");
4025         strcat(subcmd, cmargv[j]);
4026         strcat(subcmd, "\"");
4027         }
4028     cmddsc.dsc$a_pointer = subcmd;
4029     cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
4030
4031         create_mbx(aTHX_ &child_chan,&mbxdsc);
4032 #ifdef ARGPROC_DEBUG
4033     PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
4034     PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
4035 #endif
4036     _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
4037                                0, &pid, child_st, &zero, sig_child,
4038                                &child_chan));
4039 #ifdef ARGPROC_DEBUG
4040     PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
4041 #endif
4042     sys$dclexh(&exit_block);
4043     if (NULL == freopen(mbxname, "wb", stdout))
4044         {
4045         PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
4046         }
4047 }
4048
4049 static int background_process(int argc, char **argv)
4050 {
4051 char command[2048] = "$";
4052 $DESCRIPTOR(value, "");
4053 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4054 static $DESCRIPTOR(null, "NLA0:");
4055 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4056 char pidstring[80];
4057 $DESCRIPTOR(pidstr, "");
4058 int pid;
4059 unsigned long int flags = 17, one = 1, retsts;
4060
4061     strcat(command, argv[0]);
4062     while (--argc)
4063         {
4064         strcat(command, " \"");
4065         strcat(command, *(++argv));
4066         strcat(command, "\"");
4067         }
4068     value.dsc$a_pointer = command;
4069     value.dsc$w_length = strlen(value.dsc$a_pointer);
4070     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4071     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4072     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4073         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4074     }
4075     else {
4076         _ckvmssts_noperl(retsts);
4077     }
4078 #ifdef ARGPROC_DEBUG
4079     PerlIO_printf(Perl_debug_log, "%s\n", command);
4080 #endif
4081     sprintf(pidstring, "%08X", pid);
4082     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4083     pidstr.dsc$a_pointer = pidstring;
4084     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4085     lib$set_symbol(&pidsymbol, &pidstr);
4086     return(SS$_NORMAL);
4087 }
4088 /*}}}*/
4089 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4090
4091
4092 /* OS-specific initialization at image activation (not thread startup) */
4093 /* Older VAXC header files lack these constants */
4094 #ifndef JPI$_RIGHTS_SIZE
4095 #  define JPI$_RIGHTS_SIZE 817
4096 #endif
4097 #ifndef KGB$M_SUBSYSTEM
4098 #  define KGB$M_SUBSYSTEM 0x8
4099 #endif
4100
4101 /*{{{void vms_image_init(int *, char ***)*/
4102 void
4103 vms_image_init(int *argcp, char ***argvp)
4104 {
4105   char eqv[LNM$C_NAMLENGTH+1] = "";
4106   unsigned int len, tabct = 8, tabidx = 0;
4107   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4108   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4109   unsigned short int dummy, rlen;
4110   struct dsc$descriptor_s **tabvec;
4111 #if defined(PERL_IMPLICIT_CONTEXT)
4112   pTHX = NULL;
4113 #endif
4114   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
4115                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
4116                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4117                                  {          0,                0,    0,      0} };
4118
4119   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4120   _ckvmssts_noperl(iosb[0]);
4121   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4122     if (iprv[i]) {           /* Running image installed with privs? */
4123       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
4124       will_taint = TRUE;
4125       break;
4126     }
4127   }
4128   /* Rights identifiers might trigger tainting as well. */
4129   if (!will_taint && (rlen || rsz)) {
4130     while (rlen < rsz) {
4131       /* We didn't get all the identifiers on the first pass.  Allocate a
4132        * buffer much larger than $GETJPI wants (rsz is size in bytes that
4133        * were needed to hold all identifiers at time of last call; we'll
4134        * allocate that many unsigned long ints), and go back and get 'em.
4135        * If it gave us less than it wanted to despite ample buffer space,
4136        * something's broken.  Is your system missing a system identifier?
4137        */
4138       if (rsz <= jpilist[1].buflen) {
4139          /* Perl_croak accvios when used this early in startup. */
4140          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4141                          rsz, (unsigned long) jpilist[1].buflen,
4142                          "Check your rights database for corruption.\n");
4143          exit(SS$_ABORT);
4144       }
4145       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4146       jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4147       jpilist[1].buflen = rsz * sizeof(unsigned long int);
4148       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4149       _ckvmssts_noperl(iosb[0]);
4150     }
4151     mask = jpilist[1].bufadr;
4152     /* Check attribute flags for each identifier (2nd longword); protected
4153      * subsystem identifiers trigger tainting.
4154      */
4155     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4156       if (mask[i] & KGB$M_SUBSYSTEM) {
4157         will_taint = TRUE;
4158         break;
4159       }
4160     }
4161     if (mask != rlst) Safefree(mask);
4162   }
4163   /* We need to use this hack to tell Perl it should run with tainting,
4164    * since its tainting flag may be part of the PL_curinterp struct, which
4165    * hasn't been allocated when vms_image_init() is called.
4166    */
4167   if (will_taint) {
4168     char ***newap;
4169     New(1320,newap,*argcp+2,char **);
4170     newap[0] = argvp[0];
4171     *newap[1] = "-T";
4172     Copy(argvp[1],newap[2],*argcp-1,char **);
4173     /* We orphan the old argv, since we don't know where it's come from,
4174      * so we don't know how to free it.
4175      */
4176     *argcp++; argvp = newap;
4177   }
4178   else {  /* Did user explicitly request tainting? */
4179     int i;
4180     char *cp, **av = *argvp;
4181     for (i = 1; i < *argcp; i++) {
4182       if (*av[i] != '-') break;
4183       for (cp = av[i]+1; *cp; cp++) {
4184         if (*cp == 'T') { will_taint = 1; break; }
4185         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4186                   strchr("DFIiMmx",*cp)) break;
4187       }
4188       if (will_taint) break;
4189     }
4190   }
4191
4192   for (tabidx = 0;
4193        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4194        tabidx++) {
4195     if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4196     else if (tabidx >= tabct) {
4197       tabct += 8;
4198       Renew(tabvec,tabct,struct dsc$descriptor_s *);
4199     }
4200     New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4201     tabvec[tabidx]->dsc$w_length  = 0;
4202     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
4203     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
4204     tabvec[tabidx]->dsc$a_pointer = NULL;
4205     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4206   }
4207   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4208
4209   getredirection(argcp,argvp);
4210 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4211   {
4212 # include <reentrancy.h>
4213   (void) decc$set_reentrancy(C$C_MULTITHREAD);
4214   }
4215 #endif
4216   return;
4217 }
4218 /*}}}*/
4219
4220
4221 /* trim_unixpath()
4222  * Trim Unix-style prefix off filespec, so it looks like what a shell
4223  * glob expansion would return (i.e. from specified prefix on, not
4224  * full path).  Note that returned filespec is Unix-style, regardless
4225  * of whether input filespec was VMS-style or Unix-style.
4226  *
4227  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4228  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
4229  * vector of options; at present, only bit 0 is used, and if set tells
4230  * trim unixpath to try the current default directory as a prefix when
4231  * presented with a possibly ambiguous ... wildcard.
4232  *
4233  * Returns !=0 on success, with trimmed filespec replacing contents of
4234  * fspec, and 0 on failure, with contents of fpsec unchanged.
4235  */
4236 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4237 int
4238 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4239 {
4240   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4241        *template, *base, *end, *cp1, *cp2;
4242   register int tmplen, reslen = 0, dirs = 0;
4243
4244   if (!wildspec || !fspec) return 0;
4245   if (strpbrk(wildspec,"]>:") != NULL) {
4246     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4247     else template = unixwild;
4248   }
4249   else template = wildspec;
4250   if (strpbrk(fspec,"]>:") != NULL) {
4251     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4252     else base = unixified;
4253     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4254      * check to see that final result fits into (isn't longer than) fspec */
4255     reslen = strlen(fspec);
4256   }
4257   else base = fspec;
4258
4259   /* No prefix or absolute path on wildcard, so nothing to remove */
4260   if (!*template || *template == '/') {
4261     if (base == fspec) return 1;
4262     tmplen = strlen(unixified);
4263     if (tmplen > reslen) return 0;  /* not enough space */
4264     /* Copy unixified resultant, including trailing NUL */
4265     memmove(fspec,unixified,tmplen+1);
4266     return 1;
4267   }
4268
4269   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
4270   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4271     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4272     for (cp1 = end ;cp1 >= base; cp1--)
4273       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4274         { cp1++; break; }
4275     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4276     return 1;
4277   }
4278   else {
4279     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4280     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4281     int ells = 1, totells, segdirs, match;
4282     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4283                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4284
4285     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4286     totells = ells;
4287     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4288     if (ellipsis == template && opts & 1) {
4289       /* Template begins with an ellipsis.  Since we can't tell how many
4290        * directory names at the front of the resultant to keep for an
4291        * arbitrary starting point, we arbitrarily choose the current
4292        * default directory as a starting point.  If it's there as a prefix,
4293        * clip it off.  If not, fall through and act as if the leading
4294        * ellipsis weren't there (i.e. return shortest possible path that
4295        * could match template).
4296        */
4297       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4298       for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4299         if (_tolower(*cp1) != _tolower(*cp2)) break;
4300       segdirs = dirs - totells;  /* Min # of dirs we must have left */
4301       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4302       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4303         memcpy(fspec,cp2+1,end - cp2);
4304         return 1;
4305       }
4306     }
4307     /* First off, back up over constant elements at end of path */
4308     if (dirs) {
4309       for (front = end ; front >= base; front--)
4310          if (*front == '/' && !dirs--) { front++; break; }
4311     }
4312     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4313          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
4314     if (cp1 != '\0') return 0;  /* Path too long. */
4315     lcend = cp2;
4316     *cp2 = '\0';  /* Pick up with memcpy later */
4317     lcfront = lcres + (front - base);
4318     /* Now skip over each ellipsis and try to match the path in front of it. */
4319     while (ells--) {
4320       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4321         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
4322             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
4323       if (cp1 < template) break; /* template started with an ellipsis */
4324       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4325         ellipsis = cp1; continue;
4326       }
4327       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4328       nextell = cp1;
4329       for (segdirs = 0, cp2 = tpl;
4330            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4331            cp1++, cp2++) {
4332          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4333          else *cp2 = _tolower(*cp1);  /* else lowercase for match */
4334          if (*cp2 == '/') segdirs++;
4335       }
4336       if (cp1 != ellipsis - 1) return 0; /* Path too long */
4337       /* Back up at least as many dirs as in template before matching */
4338       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4339         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4340       for (match = 0; cp1 > lcres;) {
4341         resdsc.dsc$a_pointer = cp1;
4342         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4343           match++;
4344           if (match == 1) lcfront = cp1;
4345         }
4346         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4347       }
4348       if (!match) return 0;  /* Can't find prefix ??? */
4349       if (match > 1 && opts & 1) {
4350         /* This ... wildcard could cover more than one set of dirs (i.e.
4351          * a set of similar dir names is repeated).  If the template
4352          * contains more than 1 ..., upstream elements could resolve the
4353          * ambiguity, but it's not worth a full backtracking setup here.
4354          * As a quick heuristic, clip off the current default directory
4355          * if it's present to find the trimmed spec, else use the
4356          * shortest string that this ... could cover.
4357          */
4358         char def[NAM$C_MAXRSS+1], *st;
4359
4360         if (getcwd(def, sizeof def,0) == NULL) return 0;
4361         for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4362           if (_tolower(*cp1) != _tolower(*cp2)) break;
4363         segdirs = dirs - totells;  /* Min # of dirs we must have left */
4364         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4365         if (*cp1 == '\0' && *cp2 == '/') {
4366           memcpy(fspec,cp2+1,end - cp2);
4367           return 1;
4368         }
4369         /* Nope -- stick with lcfront from above and keep going. */
4370       }
4371     }
4372     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4373     return 1;
4374     ellipsis = nextell;
4375   }
4376
4377 }  /* end of trim_unixpath() */
4378 /*}}}*/
4379
4380
4381 /*
4382  *  VMS readdir() routines.
4383  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4384  *
4385  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
4386  *  Minor modifications to original routines.
4387  */
4388
4389     /* Number of elements in vms_versions array */
4390 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
4391
4392 /*
4393  *  Open a directory, return a handle for later use.
4394  */
4395 /*{{{ DIR *opendir(char*name) */
4396 DIR *
4397 Perl_opendir(pTHX_ char *name)
4398 {
4399     DIR *dd;
4400     char dir[NAM$C_MAXRSS+1];
4401     Stat_t sb;
4402
4403     if (do_tovmspath(name,dir,0) == NULL) {
4404       return NULL;
4405     }
4406     if (flex_stat(dir,&sb) == -1) return NULL;
4407     if (!S_ISDIR(sb.st_mode)) {
4408       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
4409       return NULL;
4410     }
4411     if (!cando_by_name(S_IRUSR,0,dir)) {
4412       set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4413       return NULL;
4414     }
4415     /* Get memory for the handle, and the pattern. */
4416     New(1306,dd,1,DIR);
4417     New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4418
4419     /* Fill in the fields; mainly playing with the descriptor. */
4420     (void)sprintf(dd->pattern, "%s*.*",dir);
4421     dd->context = 0;
4422     dd->count = 0;
4423     dd->vms_wantversions = 0;
4424     dd->pat.dsc$a_pointer = dd->pattern;
4425     dd->pat.dsc$w_length = strlen(dd->pattern);
4426     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4427     dd->pat.dsc$b_class = DSC$K_CLASS_S;
4428
4429     return dd;
4430 }  /* end of opendir() */
4431 /*}}}*/
4432
4433 /*
4434  *  Set the flag to indicate we want versions or not.
4435  */
4436 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4437 void
4438 vmsreaddirversions(DIR *dd, int flag)
4439 {
4440     dd->vms_wantversions = flag;
4441 }
4442 /*}}}*/
4443
4444 /*
4445  *  Free up an opened directory.
4446  */
4447 /*{{{ void closedir(DIR *dd)*/
4448 void
4449 closedir(DIR *dd)
4450 {
4451     (void)lib$find_file_end(&dd->context);
4452     Safefree(dd->pattern);
4453     Safefree((char *)dd);
4454 }
4455 /*}}}*/
4456
4457 /*
4458  *  Collect all the version numbers for the current file.
4459  */
4460 static void
4461 collectversions(pTHX_ DIR *dd)
4462 {
4463     struct dsc$descriptor_s     pat;
4464     struct dsc$descriptor_s     res;
4465     struct dirent *e;
4466     char *p, *text, buff[sizeof dd->entry.d_name];
4467     int i;
4468     unsigned long context, tmpsts;
4469
4470     /* Convenient shorthand. */
4471     e = &dd->entry;
4472
4473     /* Add the version wildcard, ignoring the "*.*" put on before */
4474     i = strlen(dd->pattern);
4475     New(1308,text,i + e->d_namlen + 3,char);
4476     (void)strcpy(text, dd->pattern);
4477     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4478
4479     /* Set up the pattern descriptor. */
4480     pat.dsc$a_pointer = text;
4481     pat.dsc$w_length = i + e->d_namlen - 1;
4482     pat.dsc$b_dtype = DSC$K_DTYPE_T;
4483     pat.dsc$b_class = DSC$K_CLASS_S;
4484
4485     /* Set up result descriptor. */
4486     res.dsc$a_pointer = buff;
4487     res.dsc$w_length = sizeof buff - 2;
4488     res.dsc$b_dtype = DSC$K_DTYPE_T;
4489     res.dsc$b_class = DSC$K_CLASS_S;
4490
4491     /* Read files, collecting versions. */
4492     for (context = 0, e->vms_verscount = 0;
4493          e->vms_verscount < VERSIZE(e);
4494          e->vms_verscount++) {
4495         tmpsts = lib$find_file(&pat, &res, &context);
4496         if (tmpsts == RMS$_NMF || context == 0) break;
4497         _ckvmssts(tmpsts);
4498         buff[sizeof buff - 1] = '\0';
4499         if ((p = strchr(buff, ';')))
4500             e->vms_versions[e->vms_verscount] = atoi(p + 1);
4501         else
4502             e->vms_versions[e->vms_verscount] = -1;
4503     }
4504
4505     _ckvmssts(lib$find_file_end(&context));
4506     Safefree(text);
4507
4508 }  /* end of collectversions() */
4509
4510 /*
4511  *  Read the next entry from the directory.
4512  */
4513 /*{{{ struct dirent *readdir(DIR *dd)*/
4514 struct dirent *
4515 Perl_readdir(pTHX_ DIR *dd)
4516 {
4517     struct dsc$descriptor_s     res;
4518     char *p, buff[sizeof dd->entry.d_name];
4519     unsigned long int tmpsts;
4520
4521     /* Set up result descriptor, and get next file. */
4522     res.dsc$a_pointer = buff;
4523     res.dsc$w_length = sizeof buff - 2;
4524     res.dsc$b_dtype = DSC$K_DTYPE_T;
4525     res.dsc$b_class = DSC$K_CLASS_S;
4526     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4527     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
4528     if (!(tmpsts & 1)) {
4529       set_vaxc_errno(tmpsts);
4530       switch (tmpsts) {
4531         case RMS$_PRV:
4532           set_errno(EACCES); break;
4533         case RMS$_DEV:
4534           set_errno(ENODEV); break;
4535         case RMS$_DIR:
4536           set_errno(ENOTDIR); break;
4537         case RMS$_FNF: case RMS$_DNF:
4538           set_errno(ENOENT); break;
4539         default:
4540           set_errno(EVMSERR);
4541       }
4542       return NULL;
4543     }
4544     dd->count++;
4545     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4546     buff[sizeof buff - 1] = '\0';
4547     for (p = buff; *p; p++) *p = _tolower(*p);
4548     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
4549     *p = '\0';
4550
4551     /* Skip any directory component and just copy the name. */
4552     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4553     else (void)strcpy(dd->entry.d_name, buff);
4554
4555     /* Clobber the version. */
4556     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4557
4558     dd->entry.d_namlen = strlen(dd->entry.d_name);
4559     dd->entry.vms_verscount = 0;
4560     if (dd->vms_wantversions) collectversions(aTHX_ dd);
4561     return &dd->entry;
4562
4563 }  /* end of readdir() */
4564 /*}}}*/
4565
4566 /*
4567  *  Return something that can be used in a seekdir later.
4568  */
4569 /*{{{ long telldir(DIR *dd)*/
4570 long
4571 telldir(DIR *dd)
4572 {
4573     return dd->count;
4574 }
4575 /*}}}*/
4576
4577 /*
4578  *  Return to a spot where we used to be.  Brute force.
4579  */
4580 /*{{{ void seekdir(DIR *dd,long count)*/
4581 void
4582 Perl_seekdir(pTHX_ DIR *dd, long count)
4583 {
4584     int vms_wantversions;
4585
4586     /* If we haven't done anything yet... */
4587     if (dd->count == 0)
4588         return;
4589
4590     /* Remember some state, and clear it. */
4591     vms_wantversions = dd->vms_wantversions;
4592     dd->vms_wantversions = 0;
4593     _ckvmssts(lib$find_file_end(&dd->context));
4594     dd->context = 0;
4595
4596     /* The increment is in readdir(). */
4597     for (dd->count = 0; dd->count < count; )
4598         (void)readdir(dd);
4599
4600     dd->vms_wantversions = vms_wantversions;
4601
4602 }  /* end of seekdir() */
4603 /*}}}*/
4604
4605 /* VMS subprocess management
4606  *
4607  * my_vfork() - just a vfork(), after setting a flag to record that
4608  * the current script is trying a Unix-style fork/exec.
4609  *
4610  * vms_do_aexec() and vms_do_exec() are called in response to the
4611  * perl 'exec' function.  If this follows a vfork call, then they
4612  * call out the the regular perl routines in doio.c which do an
4613  * execvp (for those who really want to try this under VMS).
4614  * Otherwise, they do exactly what the perl docs say exec should
4615  * do - terminate the current script and invoke a new command
4616  * (See below for notes on command syntax.)
4617  *
4618  * do_aspawn() and do_spawn() implement the VMS side of the perl
4619  * 'system' function.
4620  *
4621  * Note on command arguments to perl 'exec' and 'system': When handled
4622  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4623  * are concatenated to form a DCL command string.  If the first arg
4624  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4625  * the the command string is handed off to DCL directly.  Otherwise,
4626  * the first token of the command is taken as the filespec of an image
4627  * to run.  The filespec is expanded using a default type of '.EXE' and
4628  * the process defaults for device, directory, etc., and if found, the resultant
4629  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4630  * the command string as parameters.  This is perhaps a bit complicated,
4631  * but I hope it will form a happy medium between what VMS folks expect
4632  * from lib$spawn and what Unix folks expect from exec.
4633  */
4634
4635 static int vfork_called;
4636
4637 /*{{{int my_vfork()*/
4638 int
4639 my_vfork()
4640 {
4641   vfork_called++;
4642   return vfork();
4643 }
4644 /*}}}*/
4645
4646
4647 static void
4648 vms_execfree(pTHX) {
4649   if (PL_Cmd) {
4650     if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4651     PL_Cmd = Nullch;
4652   }
4653   if (VMScmd.dsc$a_pointer) {
4654     Safefree(VMScmd.dsc$a_pointer);
4655     VMScmd.dsc$w_length = 0;
4656     VMScmd.dsc$a_pointer = Nullch;
4657   }
4658 }
4659
4660 static char *
4661 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4662 {
4663   char *junk, *tmps = Nullch;
4664   register size_t cmdlen = 0;
4665   size_t rlen;
4666   register SV **idx;
4667   STRLEN n_a;
4668
4669   idx = mark;
4670   if (really) {
4671     tmps = SvPV(really,rlen);
4672     if (*tmps) {
4673       cmdlen += rlen + 1;
4674       idx++;
4675     }
4676   }
4677
4678   for (idx++; idx <= sp; idx++) {
4679     if (*idx) {
4680       junk = SvPVx(*idx,rlen);
4681       cmdlen += rlen ? rlen + 1 : 0;
4682     }
4683   }
4684   New(401,PL_Cmd,cmdlen+1,char);
4685
4686   if (tmps && *tmps) {
4687     strcpy(PL_Cmd,tmps);
4688     mark++;
4689   }
4690   else *PL_Cmd = '\0';
4691   while (++mark <= sp) {
4692     if (*mark) {
4693       char *s = SvPVx(*mark,n_a);
4694       if (!*s) continue;
4695       if (*PL_Cmd) strcat(PL_Cmd," ");
4696       strcat(PL_Cmd,s);
4697     }
4698   }
4699   return PL_Cmd;
4700
4701 }  /* end of setup_argstr() */
4702
4703 #define MAX_DCL_LINE_LENGTH   255
4704
4705 static unsigned long int
4706 setup_cmddsc(pTHX_ char *cmd, int check_img)
4707 {
4708   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4709   $DESCRIPTOR(defdsc,".EXE");
4710   $DESCRIPTOR(defdsc2,".");
4711   $DESCRIPTOR(resdsc,resspec);
4712   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4713   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4714   register char *s, *rest, *cp, *wordbreak;
4715   register int isdcl;
4716
4717   if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
4718     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
4719   s = cmd;
4720   while (*s && isspace(*s)) s++;
4721
4722   if (*s == '@' || *s == '$') {
4723     vmsspec[0] = *s;  rest = s + 1;
4724     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4725   }
4726   else { cp = vmsspec; rest = s; }
4727   if (*rest == '.' || *rest == '/') {
4728     char *cp2;
4729     for (cp2 = resspec;
4730          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4731          rest++, cp2++) *cp2 = *rest;
4732     *cp2 = '\0';
4733     if (do_tovmsspec(resspec,cp,0)) {
4734       s = vmsspec;
4735       if (*rest) {
4736         for (cp2 = vmsspec + strlen(vmsspec);
4737              *rest && cp2 - vmsspec < sizeof vmsspec;
4738              rest++, cp2++) *cp2 = *rest;
4739         *cp2 = '\0';
4740       }
4741     }
4742   }
4743   /* Intuit whether verb (first word of cmd) is a DCL command:
4744    *   - if first nonspace char is '@', it's a DCL indirection
4745    * otherwise
4746    *   - if verb contains a filespec separator, it's not a DCL command
4747    *   - if it doesn't, caller tells us whether to default to a DCL
4748    *     command, or to a local image unless told it's DCL (by leading '$')
4749    */
4750   if (*s == '@') isdcl = 1;
4751   else {
4752     register char *filespec = strpbrk(s,":<[.;");
4753     rest = wordbreak = strpbrk(s," \"\t/");
4754     if (!wordbreak) wordbreak = s + strlen(s);
4755     if (*s == '$') check_img = 0;
4756     if (filespec && (filespec < wordbreak)) isdcl = 0;
4757     else isdcl = !check_img;
4758   }
4759
4760   if (!isdcl) {
4761     imgdsc.dsc$a_pointer = s;
4762     imgdsc.dsc$w_length = wordbreak - s;
4763     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4764     if (!(retsts&1)) {
4765         _ckvmssts(lib$find_file_end(&cxt));
4766         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4767     if (!(retsts & 1) && *s == '$') {
4768           _ckvmssts(lib$find_file_end(&cxt));
4769       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4770       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4771           if (!(retsts&1)) {
4772       _ckvmssts(lib$find_file_end(&cxt));
4773             retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4774           }
4775     }
4776     }
4777     _ckvmssts(lib$find_file_end(&cxt));
4778
4779     if (retsts & 1) {
4780       FILE *fp;
4781       s = resspec;
4782       while (*s && !isspace(*s)) s++;
4783       *s = '\0';
4784
4785       /* check that it's really not DCL with no file extension */
4786       fp = fopen(resspec,"r","ctx=bin,shr=get");
4787       if (fp) {
4788         char b[4] = {0,0,0,0};
4789         read(fileno(fp),b,4);
4790         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4791         fclose(fp);
4792       }
4793       if (check_img && isdcl) return RMS$_FNF;
4794
4795       if (cando_by_name(S_IXUSR,0,resspec)) {
4796         New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4797         if (!isdcl) {
4798             strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4799         } else {
4800             strcpy(VMScmd.dsc$a_pointer,"@");
4801         }
4802         strcat(VMScmd.dsc$a_pointer,resspec);
4803         if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4804         VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4805         return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
4806       }
4807       else retsts = RMS$_PRV;
4808     }
4809   }
4810   /* It's either a DCL command or we couldn't find a suitable image */
4811   VMScmd.dsc$w_length = strlen(cmd);
4812   if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4813   else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4814   if (!(retsts & 1)) {
4815     /* just hand off status values likely to be due to user error */
4816     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4817         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4818        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4819     else { _ckvmssts(retsts); }
4820   }
4821
4822   return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
4823
4824 }  /* end of setup_cmddsc() */
4825
4826
4827 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4828 bool
4829 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
4830 {
4831   if (sp > mark) {
4832     if (vfork_called) {           /* this follows a vfork - act Unixish */
4833       vfork_called--;
4834       if (vfork_called < 0) {
4835         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4836         vfork_called = 0;
4837       }
4838       else return do_aexec(really,mark,sp);
4839     }
4840                                            /* no vfork - act VMSish */
4841     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
4842
4843   }
4844
4845   return FALSE;
4846 }  /* end of vms_do_aexec() */
4847 /*}}}*/
4848
4849 /* {{{bool vms_do_exec(char *cmd) */
4850 bool
4851 Perl_vms_do_exec(pTHX_ char *cmd)
4852 {
4853
4854   if (vfork_called) {             /* this follows a vfork - act Unixish */
4855     vfork_called--;
4856     if (vfork_called < 0) {
4857       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4858       vfork_called = 0;
4859     }
4860     else return do_exec(cmd);
4861   }
4862
4863   {                               /* no vfork - act VMSish */
4864     unsigned long int retsts;
4865
4866     TAINT_ENV();
4867     TAINT_PROPER("exec");
4868     if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1)
4869       retsts = lib$do_command(&VMScmd);
4870
4871     switch (retsts) {
4872       case RMS$_FNF: case RMS$_DNF:
4873         set_errno(ENOENT); break;
4874       case RMS$_DIR:
4875         set_errno(ENOTDIR); break;
4876       case RMS$_DEV:
4877         set_errno(ENODEV); break;
4878       case RMS$_PRV:
4879         set_errno(EACCES); break;
4880       case RMS$_SYN:
4881         set_errno(EINVAL); break;
4882       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4883         set_errno(E2BIG); break;
4884       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4885         _ckvmssts(retsts); /* fall through */
4886       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4887         set_errno(EVMSERR);
4888     }
4889     set_vaxc_errno(retsts);
4890     if (ckWARN(WARN_EXEC)) {
4891       Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4892              VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
4893     }
4894     vms_execfree(aTHX);
4895   }
4896
4897   return FALSE;
4898
4899 }  /* end of vms_do_exec() */
4900 /*}}}*/
4901
4902 unsigned long int Perl_do_spawn(pTHX_ char *);
4903
4904 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
4905 unsigned long int
4906 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
4907 {
4908   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
4909
4910   return SS$_ABORT;
4911 }  /* end of do_aspawn() */
4912 /*}}}*/
4913
4914 /* {{{unsigned long int do_spawn(char *cmd) */
4915 unsigned long int
4916 Perl_do_spawn(pTHX_ char *cmd)
4917 {
4918   unsigned long int sts, substs, hadcmd = 1;
4919
4920   TAINT_ENV();
4921   TAINT_PROPER("spawn");
4922   if (!cmd || !*cmd) {
4923     hadcmd = 0;
4924     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
4925   }
4926   else {
4927     sts = setup_cmddsc(aTHX_ cmd,0);
4928     if (sts & 1) {
4929         sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
4930     } else {
4931         substs = sts; /* didn't spawn, use command setup failure for return */
4932     }
4933   }
4934
4935   if (!(sts & 1)) {
4936     switch (sts) {
4937       case RMS$_FNF:  case RMS$_DNF:
4938         set_errno(ENOENT); break;
4939       case RMS$_DIR:
4940         set_errno(ENOTDIR); break;
4941       case RMS$_DEV:
4942         set_errno(ENODEV); break;
4943       case RMS$_PRV:
4944         set_errno(EACCES); break;
4945       case RMS$_SYN:
4946         set_errno(EINVAL); break;
4947       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4948         set_errno(E2BIG); break;
4949       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4950         _ckvmssts(sts); /* fall through */
4951       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4952         set_errno(EVMSERR);
4953     }
4954     set_vaxc_errno(sts);
4955     if (ckWARN(WARN_EXEC)) {
4956       Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
4957              hadcmd ? VMScmd.dsc$w_length :  0,
4958              hadcmd ? VMScmd.dsc$a_pointer : "",
4959              Strerror(errno));
4960     }
4961   }
4962   vms_execfree(aTHX);
4963   return substs;
4964
4965 }  /* end of do_spawn() */
4966 /*}}}*/
4967
4968
4969 static unsigned int *sockflags, sockflagsize;
4970
4971 /*
4972  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
4973  * routines found in some versions of the CRTL can't deal with sockets.
4974  * We don't shim the other file open routines since a socket isn't
4975  * likely to be opened by a name.
4976  */
4977 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
4978 FILE *my_fdopen(int fd, const char *mode)
4979 {
4980   FILE *fp = fdopen(fd, (char *) mode);
4981
4982   if (fp) {
4983     unsigned int fdoff = fd / sizeof(unsigned int);
4984     struct stat sbuf; /* native stat; we don't need flex_stat */
4985     if (!sockflagsize || fdoff > sockflagsize) {
4986       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
4987       else           New  (1324,sockflags,fdoff+2,unsigned int);
4988       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
4989       sockflagsize = fdoff + 2;
4990     }
4991     if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
4992       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
4993   }
4994   return fp;
4995
4996 }
4997 /*}}}*/
4998
4999
5000 /*
5001  * Clear the corresponding bit when the (possibly) socket stream is closed.
5002  * There still a small hole: we miss an implicit close which might occur
5003  * via freopen().  >> Todo
5004  */
5005 /*{{{ int my_fclose(FILE *fp)*/
5006 int my_fclose(FILE *fp) {
5007   if (fp) {
5008     unsigned int fd = fileno(fp);
5009     unsigned int fdoff = fd / sizeof(unsigned int);
5010
5011     if (sockflagsize && fdoff <= sockflagsize)
5012       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5013   }
5014   return fclose(fp);
5015 }
5016 /*}}}*/
5017
5018
5019 /*
5020  * A simple fwrite replacement which outputs itmsz*nitm chars without
5021  * introducing record boundaries every itmsz chars.
5022  * We are using fputs, which depends on a terminating null.  We may
5023  * well be writing binary data, so we need to accommodate not only
5024  * data with nulls sprinkled in the middle but also data with no null
5025  * byte at the end.
5026  */
5027 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5028 int
5029 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5030 {
5031   register char *cp, *end, *cpd, *data;
5032   register unsigned int fd = fileno(dest);
5033   register unsigned int fdoff = fd / sizeof(unsigned int);
5034   int retval;
5035   int bufsize = itmsz * nitm + 1;
5036
5037   if (fdoff < sockflagsize &&
5038       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5039     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5040     return nitm;
5041   }
5042
5043   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5044   memcpy( data, src, itmsz*nitm );
5045   data[itmsz*nitm] = '\0';
5046
5047   end = data + itmsz * nitm;
5048   retval = (int) nitm; /* on success return # items written */
5049
5050   cpd = data;
5051   while (cpd <= end) {
5052     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5053     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5054     if (cp < end)
5055       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5056     cpd = cp + 1;
5057   }
5058
5059   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5060   return retval;
5061
5062 }  /* end of my_fwrite() */
5063 /*}}}*/
5064
5065 /*{{{ int my_flush(FILE *fp)*/
5066 int
5067 Perl_my_flush(pTHX_ FILE *fp)
5068 {
5069     int res;
5070     if ((res = fflush(fp)) == 0 && fp) {
5071 #ifdef VMS_DO_SOCKETS
5072         Stat_t s;
5073         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5074 #endif
5075             res = fsync(fileno(fp));
5076     }
5077 /*
5078  * If the flush succeeded but set end-of-file, we need to clear
5079  * the error because our caller may check ferror().  BTW, this
5080  * probably means we just flushed an empty file.
5081  */
5082     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5083
5084     return res;
5085 }
5086 /*}}}*/
5087
5088 /*
5089  * Here are replacements for the following Unix routines in the VMS environment:
5090  *      getpwuid    Get information for a particular UIC or UID
5091  *      getpwnam    Get information for a named user
5092  *      getpwent    Get information for each user in the rights database
5093  *      setpwent    Reset search to the start of the rights database
5094  *      endpwent    Finish searching for users in the rights database
5095  *
5096  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5097  * (defined in pwd.h), which contains the following fields:-
5098  *      struct passwd {
5099  *              char        *pw_name;    Username (in lower case)
5100  *              char        *pw_passwd;  Hashed password
5101  *              unsigned int pw_uid;     UIC
5102  *              unsigned int pw_gid;     UIC group  number
5103  *              char        *pw_unixdir; Default device/directory (VMS-style)
5104  *              char        *pw_gecos;   Owner name
5105  *              char        *pw_dir;     Default device/directory (Unix-style)
5106  *              char        *pw_shell;   Default CLI name (eg. DCL)
5107  *      };
5108  * If the specified user does not exist, getpwuid and getpwnam return NULL.
5109  *
5110  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5111  * not the UIC member number (eg. what's returned by getuid()),
5112  * getpwuid() can accept either as input (if uid is specified, the caller's
5113  * UIC group is used), though it won't recognise gid=0.
5114  *
5115  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5116  * information about other users in your group or in other groups, respectively.
5117  * If the required privilege is not available, then these routines fill only
5118  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5119  * string).
5120  *
5121  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5122  */
5123
5124 /* sizes of various UAF record fields */
5125 #define UAI$S_USERNAME 12
5126 #define UAI$S_IDENT    31
5127 #define UAI$S_OWNER    31
5128 #define UAI$S_DEFDEV   31
5129 #define UAI$S_DEFDIR   63
5130 #define UAI$S_DEFCLI   31
5131 #define UAI$S_PWD       8
5132
5133 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
5134                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5135                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
5136
5137 static char __empty[]= "";
5138 static struct passwd __passwd_empty=
5139     {(char *) __empty, (char *) __empty, 0, 0,
5140      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5141 static int contxt= 0;
5142 static struct passwd __pwdcache;
5143 static char __pw_namecache[UAI$S_IDENT+1];
5144
5145 /*
5146  * This routine does most of the work extracting the user information.
5147  */
5148 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5149 {
5150     static struct {
5151         unsigned char length;
5152         char pw_gecos[UAI$S_OWNER+1];
5153     } owner;
5154     static union uicdef uic;
5155     static struct {
5156         unsigned char length;
5157         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5158     } defdev;
5159     static struct {
5160         unsigned char length;
5161         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5162     } defdir;
5163     static struct {
5164         unsigned char length;
5165         char pw_shell[UAI$S_DEFCLI+1];
5166     } defcli;
5167     static char pw_passwd[UAI$S_PWD+1];
5168
5169     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5170     struct dsc$descriptor_s name_desc;
5171     unsigned long int sts;
5172
5173     static struct itmlst_3 itmlst[]= {
5174         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
5175         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
5176         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
5177         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
5178         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
5179         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
5180         {0,                0,           NULL,    NULL}};
5181
5182     name_desc.dsc$w_length=  strlen(name);
5183     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5184     name_desc.dsc$b_class=   DSC$K_CLASS_S;
5185     name_desc.dsc$a_pointer= (char *) name;
5186
5187 /*  Note that sys$getuai returns many fields as counted strings. */
5188     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5189     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5190       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5191     }
5192     else { _ckvmssts(sts); }
5193     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
5194
5195     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
5196     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5197     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5198     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5199     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5200     owner.pw_gecos[lowner]=            '\0';
5201     defdev.pw_dir[ldefdev+ldefdir]= '\0';
5202     defcli.pw_shell[ldefcli]=          '\0';
5203     if (valid_uic(uic)) {
5204         pwd->pw_uid= uic.uic$l_uic;
5205         pwd->pw_gid= uic.uic$v_group;
5206     }
5207     else
5208       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5209     pwd->pw_passwd=  pw_passwd;
5210     pwd->pw_gecos=   owner.pw_gecos;
5211     pwd->pw_dir=     defdev.pw_dir;
5212     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5213     pwd->pw_shell=   defcli.pw_shell;
5214     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5215         int ldir;
5216         ldir= strlen(pwd->pw_unixdir) - 1;
5217         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5218     }
5219     else
5220         strcpy(pwd->pw_unixdir, pwd->pw_dir);
5221     __mystrtolower(pwd->pw_unixdir);
5222     return 1;
5223 }
5224
5225 /*
5226  * Get information for a named user.
5227 */
5228 /*{{{struct passwd *getpwnam(char *name)*/
5229 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5230 {
5231     struct dsc$descriptor_s name_desc;
5232     union uicdef uic;
5233     unsigned long int status, sts;
5234
5235     __pwdcache = __passwd_empty;
5236     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5237       /* We still may be able to determine pw_uid and pw_gid */
5238       name_desc.dsc$w_length=  strlen(name);
5239       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5240       name_desc.dsc$b_class=   DSC$K_CLASS_S;
5241       name_desc.dsc$a_pointer= (char *) name;
5242       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5243         __pwdcache.pw_uid= uic.uic$l_uic;
5244         __pwdcache.pw_gid= uic.uic$v_group;
5245       }
5246       else {
5247         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5248           set_vaxc_errno(sts);
5249           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5250           return NULL;
5251         }
5252         else { _ckvmssts(sts); }
5253       }
5254     }
5255     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5256     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5257     __pwdcache.pw_name= __pw_namecache;
5258     return &__pwdcache;
5259 }  /* end of my_getpwnam() */
5260 /*}}}*/
5261
5262 /*
5263  * Get information for a particular UIC or UID.
5264  * Called by my_getpwent with uid=-1 to list all users.
5265 */
5266 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5267 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5268 {
5269     const $DESCRIPTOR(name_desc,__pw_namecache);
5270     unsigned short lname;
5271     union uicdef uic;
5272     unsigned long int status;
5273
5274     if (uid == (unsigned int) -1) {
5275       do {
5276         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5277         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5278           set_vaxc_errno(status);
5279           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5280           my_endpwent();
5281           return NULL;
5282         }
5283         else { _ckvmssts(status); }
5284       } while (!valid_uic (uic));
5285     }
5286     else {
5287       uic.uic$l_uic= uid;
5288       if (!uic.uic$v_group)
5289         uic.uic$v_group= PerlProc_getgid();
5290       if (valid_uic(uic))
5291         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5292       else status = SS$_IVIDENT;
5293       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5294           status == RMS$_PRV) {
5295         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5296         return NULL;
5297       }
5298       else { _ckvmssts(status); }
5299     }
5300     __pw_namecache[lname]= '\0';
5301     __mystrtolower(__pw_namecache);
5302
5303     __pwdcache = __passwd_empty;
5304     __pwdcache.pw_name = __pw_namecache;
5305
5306 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5307     The identifier's value is usually the UIC, but it doesn't have to be,
5308     so if we can, we let fillpasswd update this. */
5309     __pwdcache.pw_uid =  uic.uic$l_uic;
5310     __pwdcache.pw_gid =  uic.uic$v_group;
5311
5312     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5313     return &__pwdcache;
5314
5315 }  /* end of my_getpwuid() */
5316 /*}}}*/
5317
5318 /*
5319  * Get information for next user.
5320 */
5321 /*{{{struct passwd *my_getpwent()*/
5322 struct passwd *Perl_my_getpwent(pTHX)
5323 {
5324     return (my_getpwuid((unsigned int) -1));
5325 }
5326 /*}}}*/
5327
5328 /*
5329  * Finish searching rights database for users.
5330 */
5331 /*{{{void my_endpwent()*/
5332 void Perl_my_endpwent(pTHX)
5333 {
5334     if (contxt) {
5335       _ckvmssts(sys$finish_rdb(&contxt));
5336       contxt= 0;
5337     }
5338 }
5339 /*}}}*/
5340
5341 #ifdef HOMEGROWN_POSIX_SIGNALS
5342   /* Signal handling routines, pulled into the core from POSIX.xs.
5343    *
5344    * We need these for threads, so they've been rolled into the core,
5345    * rather than left in POSIX.xs.
5346    *
5347    * (DRS, Oct 23, 1997)
5348    */
5349
5350   /* sigset_t is atomic under VMS, so these routines are easy */
5351 /*{{{int my_sigemptyset(sigset_t *) */
5352 int my_sigemptyset(sigset_t *set) {
5353     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5354     *set = 0; return 0;
5355 }
5356 /*}}}*/
5357
5358
5359 /*{{{int my_sigfillset(sigset_t *)*/
5360 int my_sigfillset(sigset_t *set) {
5361     int i;
5362     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5363     for (i = 0; i < NSIG; i++) *set |= (1 << i);
5364     return 0;
5365 }
5366 /*}}}*/
5367
5368
5369 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5370 int my_sigaddset(sigset_t *set, int sig) {
5371     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5372     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5373     *set |= (1 << (sig - 1));
5374     return 0;
5375 }
5376 /*}}}*/
5377
5378
5379 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5380 int my_sigdelset(sigset_t *set, int sig) {
5381     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5382     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5383     *set &= ~(1 << (sig - 1));
5384     return 0;
5385 }
5386 /*}}}*/
5387
5388
5389 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5390 int my_sigismember(sigset_t *set, int sig) {
5391     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5392     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5393     *set & (1 << (sig - 1));
5394 }
5395 /*}}}*/
5396
5397
5398 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5399 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5400     sigset_t tempmask;
5401
5402     /* If set and oset are both null, then things are badly wrong. Bail out. */
5403     if ((oset == NULL) && (set == NULL)) {
5404       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5405       return -1;
5406     }
5407
5408     /* If set's null, then we're just handling a fetch. */
5409     if (set == NULL) {
5410         tempmask = sigblock(0);
5411     }
5412     else {
5413       switch (how) {
5414       case SIG_SETMASK:
5415         tempmask = sigsetmask(*set);
5416         break;
5417       case SIG_BLOCK:
5418         tempmask = sigblock(*set);
5419         break;
5420       case SIG_UNBLOCK:
5421         tempmask = sigblock(0);
5422         sigsetmask(*oset & ~tempmask);
5423         break;
5424       default:
5425         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5426         return -1;
5427       }
5428     }
5429
5430     /* Did they pass us an oset? If so, stick our holding mask into it */
5431     if (oset)
5432       *oset = tempmask;
5433
5434     return 0;
5435 }
5436 /*}}}*/
5437 #endif  /* HOMEGROWN_POSIX_SIGNALS */
5438
5439
5440 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5441  * my_utime(), and flex_stat(), all of which operate on UTC unless
5442  * VMSISH_TIMES is true.
5443  */
5444 /* method used to handle UTC conversions:
5445  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
5446  */
5447 static int gmtime_emulation_type;
5448 /* number of secs to add to UTC POSIX-style time to get local time */
5449 static long int utc_offset_secs;
5450
5451 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5452  * in vmsish.h.  #undef them here so we can call the CRTL routines
5453  * directly.
5454  */
5455 #undef gmtime
5456 #undef localtime
5457 #undef time
5458
5459
5460 /*
5461  * DEC C previous to 6.0 corrupts the behavior of the /prefix
5462  * qualifier with the extern prefix pragma.  This provisional
5463  * hack circumvents this prefix pragma problem in previous
5464  * precompilers.
5465  */
5466 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5467 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5468 #    pragma __extern_prefix save
5469 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
5470 #    define gmtime decc$__utctz_gmtime
5471 #    define localtime decc$__utctz_localtime
5472 #    define time decc$__utc_time
5473 #    pragma __extern_prefix restore
5474
5475      struct tm *gmtime(), *localtime();
5476
5477 #  endif
5478 #endif
5479
5480
5481 static time_t toutc_dst(time_t loc) {
5482   struct tm *rsltmp;
5483
5484   if ((rsltmp = localtime(&loc)) == NULL) return -1;
5485   loc -= utc_offset_secs;
5486   if (rsltmp->tm_isdst) loc -= 3600;
5487   return loc;
5488 }
5489 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
5490        ((gmtime_emulation_type || my_time(NULL)), \
5491        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5492        ((secs) - utc_offset_secs))))
5493
5494 static time_t toloc_dst(time_t utc) {
5495   struct tm *rsltmp;
5496
5497   utc += utc_offset_secs;
5498   if ((rsltmp = localtime(&utc)) == NULL) return -1;
5499   if (rsltmp->tm_isdst) utc += 3600;
5500   return utc;
5501 }
5502 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
5503        ((gmtime_emulation_type || my_time(NULL)), \
5504        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5505        ((secs) + utc_offset_secs))))
5506
5507 #ifndef RTL_USES_UTC
5508 /*
5509
5510     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
5511         DST starts on 1st sun of april      at 02:00  std time
5512             ends on last sun of october     at 02:00  dst time
5513     see the UCX management command reference, SET CONFIG TIMEZONE
5514     for formatting info.
5515
5516     No, it's not as general as it should be, but then again, NOTHING
5517     will handle UK times in a sensible way.
5518 */
5519
5520
5521 /*
5522     parse the DST start/end info:
5523     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5524 */
5525
5526 static char *
5527 tz_parse_startend(char *s, struct tm *w, int *past)
5528 {
5529     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5530     int ly, dozjd, d, m, n, hour, min, sec, j, k;
5531     time_t g;
5532
5533     if (!s)    return 0;
5534     if (!w) return 0;
5535     if (!past) return 0;
5536
5537     ly = 0;
5538     if (w->tm_year % 4        == 0) ly = 1;
5539     if (w->tm_year % 100      == 0) ly = 0;
5540     if (w->tm_year+1900 % 400 == 0) ly = 1;
5541     if (ly) dinm[1]++;
5542
5543     dozjd = isdigit(*s);
5544     if (*s == 'J' || *s == 'j' || dozjd) {
5545         if (!dozjd && !isdigit(*++s)) return 0;
5546         d = *s++ - '0';
5547         if (isdigit(*s)) {
5548             d = d*10 + *s++ - '0';
5549             if (isdigit(*s)) {
5550                 d = d*10 + *s++ - '0';
5551             }
5552         }
5553         if (d == 0) return 0;
5554         if (d > 366) return 0;
5555         d--;
5556         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
5557         g = d * 86400;
5558         dozjd = 1;
5559     } else if (*s == 'M' || *s == 'm') {
5560         if (!isdigit(*++s)) return 0;
5561         m = *s++ - '0';
5562         if (isdigit(*s)) m = 10*m + *s++ - '0';
5563         if (*s != '.') return 0;
5564         if (!isdigit(*++s)) return 0;
5565         n = *s++ - '0';
5566         if (n < 1 || n > 5) return 0;
5567         if (*s != '.') return 0;
5568         if (!isdigit(*++s)) return 0;
5569         d = *s++ - '0';
5570         if (d > 6) return 0;
5571     }
5572
5573     if (*s == '/') {
5574         if (!isdigit(*++s)) return 0;
5575         hour = *s++ - '0';
5576         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5577         if (*s == ':') {
5578             if (!isdigit(*++s)) return 0;
5579             min = *s++ - '0';
5580             if (isdigit(*s)) min = 10*min + *s++ - '0';
5581             if (*s == ':') {
5582                 if (!isdigit(*++s)) return 0;
5583                 sec = *s++ - '0';
5584                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5585             }
5586         }
5587     } else {
5588         hour = 2;
5589         min = 0;
5590         sec = 0;
5591     }
5592
5593     if (dozjd) {
5594         if (w->tm_yday < d) goto before;
5595         if (w->tm_yday > d) goto after;
5596     } else {
5597         if (w->tm_mon+1 < m) goto before;
5598         if (w->tm_mon+1 > m) goto after;
5599
5600         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
5601         k = d - j; /* mday of first d */
5602         if (k <= 0) k += 7;
5603         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
5604         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5605         if (w->tm_mday < k) goto before;
5606         if (w->tm_mday > k) goto after;
5607     }
5608
5609     if (w->tm_hour < hour) goto before;
5610     if (w->tm_hour > hour) goto after;
5611     if (w->tm_min  < min)  goto before;
5612     if (w->tm_min  > min)  goto after;
5613     if (w->tm_sec  < sec)  goto before;
5614     goto after;
5615
5616 before:
5617     *past = 0;
5618     return s;
5619 after:
5620     *past = 1;
5621     return s;
5622 }
5623
5624
5625
5626
5627 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
5628
5629 static char *
5630 tz_parse_offset(char *s, int *offset)
5631 {
5632     int hour = 0, min = 0, sec = 0;
5633     int neg = 0;
5634     if (!s) return 0;
5635     if (!offset) return 0;
5636
5637     if (*s == '-') {neg++; s++;}
5638     if (*s == '+') s++;
5639     if (!isdigit(*s)) return 0;
5640     hour = *s++ - '0';
5641     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5642     if (hour > 24) return 0;
5643     if (*s == ':') {
5644         if (!isdigit(*++s)) return 0;
5645         min = *s++ - '0';
5646         if (isdigit(*s)) min = min*10 + (*s++ - '0');
5647         if (min > 59) return 0;
5648         if (*s == ':') {
5649             if (!isdigit(*++s)) return 0;
5650             sec = *s++ - '0';
5651             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5652             if (sec > 59) return 0;
5653         }
5654     }
5655
5656     *offset = (hour*60+min)*60 + sec;
5657     if (neg) *offset = -*offset;
5658     return s;
5659 }
5660
5661 /*
5662     input time is w, whatever type of time the CRTL localtime() uses.
5663     sets dst, the zone, and the gmtoff (seconds)
5664
5665     caches the value of TZ and UCX$TZ env variables; note that
5666     my_setenv looks for these and sets a flag if they're changed
5667     for efficiency.
5668
5669     We have to watch out for the "australian" case (dst starts in
5670     october, ends in april)...flagged by "reverse" and checked by
5671     scanning through the months of the previous year.
5672
5673 */
5674
5675 static int
5676 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5677 {
5678     time_t when;
5679     struct tm *w2;
5680     char *s,*s2;
5681     char *dstzone, *tz, *s_start, *s_end;
5682     int std_off, dst_off, isdst;
5683     int y, dststart, dstend;
5684     static char envtz[1025];  /* longer than any logical, symbol, ... */
5685     static char ucxtz[1025];
5686     static char reversed = 0;
5687
5688     if (!w) return 0;
5689
5690     if (tz_updated) {
5691         tz_updated = 0;
5692         reversed = -1;  /* flag need to check  */
5693         envtz[0] = ucxtz[0] = '\0';
5694         tz = my_getenv("TZ",0);
5695         if (tz) strcpy(envtz, tz);
5696         tz = my_getenv("UCX$TZ",0);
5697         if (tz) strcpy(ucxtz, tz);
5698         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
5699     }
5700     tz = envtz;
5701     if (!*tz) tz = ucxtz;
5702
5703     s = tz;
5704     while (isalpha(*s)) s++;
5705     s = tz_parse_offset(s, &std_off);
5706     if (!s) return 0;
5707     if (!*s) {                  /* no DST, hurray we're done! */
5708         isdst = 0;
5709         goto done;
5710     }
5711
5712     dstzone = s;
5713     while (isalpha(*s)) s++;
5714     s2 = tz_parse_offset(s, &dst_off);
5715     if (s2) {
5716         s = s2;
5717     } else {
5718         dst_off = std_off - 3600;
5719     }
5720
5721     if (!*s) {      /* default dst start/end?? */
5722         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
5723             s = strchr(ucxtz,',');
5724         }
5725         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
5726     }
5727     if (*s != ',') return 0;
5728
5729     when = *w;
5730     when = _toutc(when);      /* convert to utc */
5731     when = when - std_off;    /* convert to pseudolocal time*/
5732
5733     w2 = localtime(&when);
5734     y = w2->tm_year;
5735     s_start = s+1;
5736     s = tz_parse_startend(s_start,w2,&dststart);
5737     if (!s) return 0;
5738     if (*s != ',') return 0;
5739
5740     when = *w;
5741     when = _toutc(when);      /* convert to utc */
5742     when = when - dst_off;    /* convert to pseudolocal time*/
5743     w2 = localtime(&when);
5744     if (w2->tm_year != y) {   /* spans a year, just check one time */
5745         when += dst_off - std_off;
5746         w2 = localtime(&when);
5747     }
5748     s_end = s+1;
5749     s = tz_parse_startend(s_end,w2,&dstend);
5750     if (!s) return 0;
5751
5752     if (reversed == -1) {  /* need to check if start later than end */
5753         int j, ds, de;
5754
5755         when = *w;
5756         if (when < 2*365*86400) {
5757             when += 2*365*86400;
5758         } else {
5759             when -= 365*86400;
5760         }
5761         w2 =localtime(&when);
5762         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
5763
5764         for (j = 0; j < 12; j++) {
5765             w2 =localtime(&when);
5766             (void) tz_parse_startend(s_start,w2,&ds);
5767             (void) tz_parse_startend(s_end,w2,&de);
5768             if (ds != de) break;
5769             when += 30*86400;
5770         }
5771         reversed = 0;
5772         if (de && !ds) reversed = 1;
5773     }
5774
5775     isdst = dststart && !dstend;
5776     if (reversed) isdst = dststart  || !dstend;
5777
5778 done:
5779     if (dst)    *dst = isdst;
5780     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
5781     if (isdst)  tz = dstzone;
5782     if (zone) {
5783         while(isalpha(*tz))  *zone++ = *tz++;
5784         *zone = '\0';
5785     }
5786     return 1;
5787 }
5788
5789 #endif /* !RTL_USES_UTC */
5790
5791 /* my_time(), my_localtime(), my_gmtime()
5792  * By default traffic in UTC time values, using CRTL gmtime() or
5793  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5794  * Note: We need to use these functions even when the CRTL has working
5795  * UTC support, since they also handle C<use vmsish qw(times);>
5796  *
5797  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
5798  * Modified by Charles Bailey <bailey@newman.upenn.edu>
5799  */
5800
5801 /*{{{time_t my_time(time_t *timep)*/
5802 time_t Perl_my_time(pTHX_ time_t *timep)
5803 {
5804   time_t when;
5805   struct tm *tm_p;
5806
5807   if (gmtime_emulation_type == 0) {
5808     int dstnow;
5809     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
5810                               /* results of calls to gmtime() and localtime() */
5811                               /* for same &base */
5812
5813     gmtime_emulation_type++;
5814     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5815       char off[LNM$C_NAMLENGTH+1];;
5816
5817       gmtime_emulation_type++;
5818       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5819         gmtime_emulation_type++;
5820         utc_offset_secs = 0;
5821         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5822       }
5823       else { utc_offset_secs = atol(off); }
5824     }
5825     else { /* We've got a working gmtime() */
5826       struct tm gmt, local;
5827
5828       gmt = *tm_p;
5829       tm_p = localtime(&base);
5830       local = *tm_p;
5831       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
5832       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5833       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
5834       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
5835     }
5836   }
5837
5838   when = time(NULL);
5839 # ifdef VMSISH_TIME
5840 # ifdef RTL_USES_UTC
5841   if (VMSISH_TIME) when = _toloc(when);
5842 # else
5843   if (!VMSISH_TIME) when = _toutc(when);
5844 # endif
5845 # endif
5846   if (timep != NULL) *timep = when;
5847   return when;
5848
5849 }  /* end of my_time() */
5850 /*}}}*/
5851
5852
5853 /*{{{struct tm *my_gmtime(const time_t *timep)*/
5854 struct tm *
5855 Perl_my_gmtime(pTHX_ const time_t *timep)
5856 {
5857   char *p;
5858   time_t when;
5859   struct tm *rsltmp;
5860
5861   if (timep == NULL) {
5862     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5863     return NULL;
5864   }
5865   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
5866
5867   when = *timep;
5868 # ifdef VMSISH_TIME
5869   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
5870 #  endif
5871 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
5872   return gmtime(&when);
5873 # else
5874   /* CRTL localtime() wants local time as input, so does no tz correction */
5875   rsltmp = localtime(&when);
5876   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
5877   return rsltmp;
5878 #endif
5879 }  /* end of my_gmtime() */
5880 /*}}}*/
5881
5882
5883 /*{{{struct tm *my_localtime(const time_t *timep)*/
5884 struct tm *
5885 Perl_my_localtime(pTHX_ const time_t *timep)
5886 {
5887   time_t when, whenutc;
5888   struct tm *rsltmp;
5889   int dst, offset;
5890
5891   if (timep == NULL) {
5892     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5893     return NULL;
5894   }
5895   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
5896   if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
5897
5898   when = *timep;
5899 # ifdef RTL_USES_UTC
5900 # ifdef VMSISH_TIME
5901   if (VMSISH_TIME) when = _toutc(when);
5902 # endif
5903   /* CRTL localtime() wants UTC as input, does tz correction itself */
5904   return localtime(&when);
5905
5906 # else /* !RTL_USES_UTC */
5907   whenutc = when;
5908 # ifdef VMSISH_TIME
5909   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
5910   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
5911 # endif
5912   dst = -1;
5913 #ifndef RTL_USES_UTC
5914   if (tz_parse(&when, &dst, 0, &offset)) {   /* truelocal determines DST*/
5915       when = whenutc - offset;                   /* pseudolocal time*/
5916   }
5917 # endif
5918   /* CRTL localtime() wants local time as input, so does no tz correction */
5919   rsltmp = localtime(&when);
5920   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
5921   return rsltmp;
5922 # endif
5923
5924 } /*  end of my_localtime() */
5925 /*}}}*/
5926
5927 /* Reset definitions for later calls */
5928 #define gmtime(t)    my_gmtime(t)
5929 #define localtime(t) my_localtime(t)
5930 #define time(t)      my_time(t)
5931
5932
5933 /* my_utime - update modification time of a file
5934  * calling sequence is identical to POSIX utime(), but under
5935  * VMS only the modification time is changed; ODS-2 does not
5936  * maintain access times.  Restrictions differ from the POSIX
5937  * definition in that the time can be changed as long as the
5938  * caller has permission to execute the necessary IO$_MODIFY $QIO;
5939  * no separate checks are made to insure that the caller is the
5940  * owner of the file or has special privs enabled.
5941  * Code here is based on Joe Meadows' FILE utility.
5942  */
5943
5944 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
5945  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
5946  * in 100 ns intervals.
5947  */
5948 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
5949
5950 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
5951 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
5952 {
5953   register int i;
5954   long int bintime[2], len = 2, lowbit, unixtime,
5955            secscale = 10000000; /* seconds --> 100 ns intervals */
5956   unsigned long int chan, iosb[2], retsts;
5957   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
5958   struct FAB myfab = cc$rms_fab;
5959   struct NAM mynam = cc$rms_nam;
5960 #if defined (__DECC) && defined (__VAX)
5961   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
5962    * at least through VMS V6.1, which causes a type-conversion warning.
5963    */
5964 #  pragma message save
5965 #  pragma message disable cvtdiftypes
5966 #endif
5967   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
5968   struct fibdef myfib;
5969 #if defined (__DECC) && defined (__VAX)
5970   /* This should be right after the declaration of myatr, but due
5971    * to a bug in VAX DEC C, this takes effect a statement early.
5972    */
5973 #  pragma message restore
5974 #endif
5975   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
5976                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
5977                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
5978
5979   if (file == NULL || *file == '\0') {
5980     set_errno(ENOENT);
5981     set_vaxc_errno(LIB$_INVARG);
5982     return -1;
5983   }
5984   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
5985
5986   if (utimes != NULL) {
5987     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
5988      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
5989      * Since time_t is unsigned long int, and lib$emul takes a signed long int
5990      * as input, we force the sign bit to be clear by shifting unixtime right
5991      * one bit, then multiplying by an extra factor of 2 in lib$emul().
5992      */
5993     lowbit = (utimes->modtime & 1) ? secscale : 0;
5994     unixtime = (long int) utimes->modtime;
5995 #   ifdef VMSISH_TIME
5996     /* If input was UTC; convert to local for sys svc */
5997     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
5998 #   endif
5999     unixtime >>= 1;  secscale <<= 1;
6000     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6001     if (!(retsts & 1)) {
6002       set_errno(EVMSERR);
6003       set_vaxc_errno(retsts);
6004       return -1;
6005     }
6006     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6007     if (!(retsts & 1)) {
6008       set_errno(EVMSERR);
6009       set_vaxc_errno(retsts);
6010       return -1;
6011     }
6012   }
6013   else {
6014     /* Just get the current time in VMS format directly */
6015     retsts = sys$gettim(bintime);
6016     if (!(retsts & 1)) {
6017       set_errno(EVMSERR);
6018       set_vaxc_errno(retsts);
6019       return -1;
6020     }
6021   }
6022
6023   myfab.fab$l_fna = vmsspec;
6024   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6025   myfab.fab$l_nam = &mynam;
6026   mynam.nam$l_esa = esa;
6027   mynam.nam$b_ess = (unsigned char) sizeof esa;
6028   mynam.nam$l_rsa = rsa;
6029   mynam.nam$b_rss = (unsigned char) sizeof rsa;
6030
6031   /* Look for the file to be affected, letting RMS parse the file
6032    * specification for us as well.  I have set errno using only
6033    * values documented in the utime() man page for VMS POSIX.
6034    */
6035   retsts = sys$parse(&myfab,0,0);
6036   if (!(retsts & 1)) {
6037     set_vaxc_errno(retsts);
6038     if      (retsts == RMS$_PRV) set_errno(EACCES);
6039     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6040     else                         set_errno(EVMSERR);
6041     return -1;
6042   }
6043   retsts = sys$search(&myfab,0,0);
6044   if (!(retsts & 1)) {
6045     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6046     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6047     set_vaxc_errno(retsts);
6048     if      (retsts == RMS$_PRV) set_errno(EACCES);
6049     else if (retsts == RMS$_FNF) set_errno(ENOENT);
6050     else                         set_errno(EVMSERR);
6051     return -1;
6052   }
6053
6054   devdsc.dsc$w_length = mynam.nam$b_dev;
6055   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6056
6057   retsts = sys$assign(&devdsc,&chan,0,0);
6058   if (!(retsts & 1)) {
6059     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6060     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6061     set_vaxc_errno(retsts);
6062     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
6063     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
6064     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
6065     else                               set_errno(EVMSERR);
6066     return -1;
6067   }
6068
6069   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6070   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6071
6072   memset((void *) &myfib, 0, sizeof myfib);
6073 #if defined(__DECC) || defined(__DECCXX)
6074   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6075   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6076   /* This prevents the revision time of the file being reset to the current
6077    * time as a result of our IO$_MODIFY $QIO. */
6078   myfib.fib$l_acctl = FIB$M_NORECORD;
6079 #else
6080   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6081   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6082   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6083 #endif
6084   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6085   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6086   myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6087   _ckvmssts(sys$dassgn(chan));
6088   if (retsts & 1) retsts = iosb[0];
6089   if (!(retsts & 1)) {
6090     set_vaxc_errno(retsts);
6091     if (retsts == SS$_NOPRIV) set_errno(EACCES);
6092     else                      set_errno(EVMSERR);
6093     return -1;
6094   }
6095
6096   return 0;
6097 }  /* end of my_utime() */
6098 /*}}}*/
6099
6100 /*
6101  * flex_stat, flex_fstat
6102  * basic stat, but gets it right when asked to stat
6103  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6104  */
6105
6106 /* encode_dev packs a VMS device name string into an integer to allow
6107  * simple comparisons. This can be used, for example, to check whether two
6108  * files are located on the same device, by comparing their encoded device
6109  * names. Even a string comparison would not do, because stat() reuses the
6110  * device name buffer for each call; so without encode_dev, it would be
6111  * necessary to save the buffer and use strcmp (this would mean a number of
6112  * changes to the standard Perl code, to say nothing of what a Perl script
6113  * would have to do.
6114  *
6115  * The device lock id, if it exists, should be unique (unless perhaps compared
6116  * with lock ids transferred from other nodes). We have a lock id if the disk is
6117  * mounted cluster-wide, which is when we tend to get long (host-qualified)
6118  * device names. Thus we use the lock id in preference, and only if that isn't
6119  * available, do we try to pack the device name into an integer (flagged by
6120  * the sign bit (LOCKID_MASK) being set).
6121  *
6122  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6123  * name and its encoded form, but it seems very unlikely that we will find
6124  * two files on different disks that share the same encoded device names,
6125  * and even more remote that they will share the same file id (if the test
6126  * is to check for the same file).
6127  *
6128  * A better method might be to use sys$device_scan on the first call, and to
6129  * search for the device, returning an index into the cached array.
6130  * The number returned would be more intelligable.
6131  * This is probably not worth it, and anyway would take quite a bit longer
6132  * on the first call.
6133  */
6134 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
6135 static mydev_t encode_dev (pTHX_ const char *dev)
6136 {
6137   int i;
6138   unsigned long int f;
6139   mydev_t enc;
6140   char c;
6141   const char *q;
6142
6143   if (!dev || !dev[0]) return 0;
6144
6145 #if LOCKID_MASK
6146   {
6147     struct dsc$descriptor_s dev_desc;
6148     unsigned long int status, lockid, item = DVI$_LOCKID;
6149
6150     /* For cluster-mounted disks, the disk lock identifier is unique, so we
6151        can try that first. */
6152     dev_desc.dsc$w_length =  strlen (dev);
6153     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
6154     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
6155     dev_desc.dsc$a_pointer = (char *) dev;
6156     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6157     if (lockid) return (lockid & ~LOCKID_MASK);
6158   }
6159 #endif
6160
6161   /* Otherwise we try to encode the device name */
6162   enc = 0;
6163   f = 1;
6164   i = 0;
6165   for (q = dev + strlen(dev); q--; q >= dev) {
6166     if (isdigit (*q))
6167       c= (*q) - '0';
6168     else if (isalpha (toupper (*q)))
6169       c= toupper (*q) - 'A' + (char)10;
6170     else
6171       continue; /* Skip '$'s */
6172     i++;
6173     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
6174     if (i>1) f *= 36;
6175     enc += f * (unsigned long int) c;
6176   }
6177   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
6178
6179 }  /* end of encode_dev() */
6180
6181 static char namecache[NAM$C_MAXRSS+1];
6182
6183 static int
6184 is_null_device(name)
6185     const char *name;
6186 {
6187     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6188        The underscore prefix, controller letter, and unit number are
6189        independently optional; for our purposes, the colon punctuation
6190        is not.  The colon can be trailed by optional directory and/or
6191        filename, but two consecutive colons indicates a nodename rather
6192        than a device.  [pr]  */
6193   if (*name == '_') ++name;
6194   if (tolower(*name++) != 'n') return 0;
6195   if (tolower(*name++) != 'l') return 0;
6196   if (tolower(*name) == 'a') ++name;
6197   if (*name == '0') ++name;
6198   return (*name++ == ':') && (*name != ':');
6199 }
6200
6201 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
6202 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6203  * subset of the applicable information.
6204  */
6205 bool
6206 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6207 {
6208   char fname_phdev[NAM$C_MAXRSS+1];
6209   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6210   else {
6211     char fname[NAM$C_MAXRSS+1];
6212     unsigned long int retsts;
6213     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6214                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6215
6216     /* If the struct mystat is stale, we're OOL; stat() overwrites the
6217        device name on successive calls */
6218     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6219     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6220     namdsc.dsc$a_pointer = fname;
6221     namdsc.dsc$w_length = sizeof fname - 1;
6222
6223     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6224                              &namdsc,&namdsc.dsc$w_length,0,0);
6225     if (retsts & 1) {
6226       fname[namdsc.dsc$w_length] = '\0';
6227 /*
6228  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6229  * but if someone has redefined that logical, Perl gets very lost.  Since
6230  * we have the physical device name from the stat buffer, just paste it on.
6231  */
6232       strcpy( fname_phdev, statbufp->st_devnam );
6233       strcat( fname_phdev, strrchr(fname, ':') );
6234
6235       return cando_by_name(bit,effective,fname_phdev);
6236     }
6237     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6238       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6239       return FALSE;
6240     }
6241     _ckvmssts(retsts);
6242     return FALSE;  /* Should never get to here */
6243   }
6244 }  /* end of cando() */
6245 /*}}}*/
6246
6247
6248 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6249 I32
6250 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6251 {
6252   static char usrname[L_cuserid];
6253   static struct dsc$descriptor_s usrdsc =
6254          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6255   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6256   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6257   unsigned short int retlen;
6258   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6259   union prvdef curprv;
6260   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6261          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6262   struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6263          {0,0,0,0}};
6264
6265   if (!fname || !*fname) return FALSE;
6266   /* Make sure we expand logical names, since sys$check_access doesn't */
6267   if (!strpbrk(fname,"/]>:")) {
6268     strcpy(fileified,fname);
6269     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6270     fname = fileified;
6271   }
6272   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6273   retlen = namdsc.dsc$w_length = strlen(vmsname);
6274   namdsc.dsc$a_pointer = vmsname;
6275   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6276       vmsname[retlen-1] == ':') {
6277     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6278     namdsc.dsc$w_length = strlen(fileified);
6279     namdsc.dsc$a_pointer = fileified;
6280   }
6281
6282   if (!usrdsc.dsc$w_length) {
6283     cuserid(usrname);
6284     usrdsc.dsc$w_length = strlen(usrname);
6285   }
6286
6287   switch (bit) {
6288     case S_IXUSR: case S_IXGRP: case S_IXOTH:
6289       access = ARM$M_EXECUTE; break;
6290     case S_IRUSR: case S_IRGRP: case S_IROTH:
6291       access = ARM$M_READ; break;
6292     case S_IWUSR: case S_IWGRP: case S_IWOTH:
6293       access = ARM$M_WRITE; break;
6294     case S_IDUSR: case S_IDGRP: case S_IDOTH:
6295       access = ARM$M_DELETE; break;
6296     default:
6297       return FALSE;
6298   }
6299
6300   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6301   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
6302       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6303       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6304     set_vaxc_errno(retsts);
6305     if (retsts == SS$_NOPRIV) set_errno(EACCES);
6306     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6307     else set_errno(ENOENT);
6308     return FALSE;
6309   }
6310   if (retsts == SS$_NORMAL) {
6311     if (!privused) return TRUE;
6312     /* We can get access, but only by using privs.  Do we have the
6313        necessary privs currently enabled? */
6314     _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6315     if ((privused & CHP$M_BYPASS) &&  !curprv.prv$v_bypass)  return FALSE;
6316     if ((privused & CHP$M_SYSPRV) &&  !curprv.prv$v_sysprv &&
6317                                       !curprv.prv$v_bypass)  return FALSE;
6318     if ((privused & CHP$M_GRPPRV) &&  !curprv.prv$v_grpprv &&
6319          !curprv.prv$v_sysprv &&      !curprv.prv$v_bypass)  return FALSE;
6320     if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6321     return TRUE;
6322   }
6323   if (retsts == SS$_ACCONFLICT) {
6324     return TRUE;
6325   }
6326   _ckvmssts(retsts);
6327
6328   return FALSE;  /* Should never get here */
6329
6330 }  /* end of cando_by_name() */
6331 /*}}}*/
6332
6333
6334 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6335 int
6336 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6337 {
6338   if (!fstat(fd,(stat_t *) statbufp)) {
6339     if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6340     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6341 #   ifdef RTL_USES_UTC
6342 #   ifdef VMSISH_TIME
6343     if (VMSISH_TIME) {
6344       statbufp->st_mtime = _toloc(statbufp->st_mtime);
6345       statbufp->st_atime = _toloc(statbufp->st_atime);
6346       statbufp->st_ctime = _toloc(statbufp->st_ctime);
6347     }
6348 #   endif
6349 #   else
6350 #   ifdef VMSISH_TIME
6351     if (!VMSISH_TIME) { /* Return UTC instead of local time */
6352 #   else
6353     if (1) {
6354 #   endif
6355       statbufp->st_mtime = _toutc(statbufp->st_mtime);
6356       statbufp->st_atime = _toutc(statbufp->st_atime);
6357       statbufp->st_ctime = _toutc(statbufp->st_ctime);
6358     }
6359 #endif
6360     return 0;
6361   }
6362   return -1;
6363
6364 }  /* end of flex_fstat() */
6365 /*}}}*/
6366
6367 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6368 int
6369 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6370 {
6371     char fileified[NAM$C_MAXRSS+1];
6372     char temp_fspec[NAM$C_MAXRSS+300];
6373     int retval = -1;
6374
6375     strcpy(temp_fspec, fspec);
6376     if (statbufp == (Stat_t *) &PL_statcache)
6377       do_tovmsspec(temp_fspec,namecache,0);
6378     if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6379       memset(statbufp,0,sizeof *statbufp);
6380       statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6381       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6382       statbufp->st_uid = 0x00010001;
6383       statbufp->st_gid = 0x0001;
6384       time((time_t *)&statbufp->st_mtime);
6385       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6386       return 0;
6387     }
6388
6389     /* Try for a directory name first.  If fspec contains a filename without
6390      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6391      * and sea:[wine.dark]water. exist, we prefer the directory here.
6392      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6393      * not sea:[wine.dark]., if the latter exists.  If the intended target is
6394      * the file with null type, specify this by calling flex_stat() with
6395      * a '.' at the end of fspec.
6396      */
6397     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6398       retval = stat(fileified,(stat_t *) statbufp);
6399       if (!retval && statbufp == (Stat_t *) &PL_statcache)
6400         strcpy(namecache,fileified);
6401     }
6402     if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6403     if (!retval) {
6404       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6405 #     ifdef RTL_USES_UTC
6406 #     ifdef VMSISH_TIME
6407       if (VMSISH_TIME) {
6408         statbufp->st_mtime = _toloc(statbufp->st_mtime);
6409         statbufp->st_atime = _toloc(statbufp->st_atime);
6410         statbufp->st_ctime = _toloc(statbufp->st_ctime);
6411       }
6412 #     endif
6413 #     else
6414 #     ifdef VMSISH_TIME
6415       if (!VMSISH_TIME) { /* Return UTC instead of local time */
6416 #     else
6417       if (1) {
6418 #     endif
6419         statbufp->st_mtime = _toutc(statbufp->st_mtime);
6420         statbufp->st_atime = _toutc(statbufp->st_atime);
6421         statbufp->st_ctime = _toutc(statbufp->st_ctime);
6422       }
6423 #     endif
6424     }
6425     return retval;
6426
6427 }  /* end of flex_stat() */
6428 /*}}}*/
6429
6430
6431 /*{{{char *my_getlogin()*/
6432 /* VMS cuserid == Unix getlogin, except calling sequence */
6433 char *
6434 my_getlogin()
6435 {
6436     static char user[L_cuserid];
6437     return cuserid(user);
6438 }
6439 /*}}}*/
6440
6441
6442 /*  rmscopy - copy a file using VMS RMS routines
6443  *
6444  *  Copies contents and attributes of spec_in to spec_out, except owner
6445  *  and protection information.  Name and type of spec_in are used as
6446  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
6447  *  should try to propagate timestamps from the input file to the output file.
6448  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
6449  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
6450  *  propagated to the output file at creation iff the output file specification
6451  *  did not contain an explicit name or type, and the revision date is always
6452  *  updated at the end of the copy operation.  If it is greater than 0, then
6453  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6454  *  other than the revision date should be propagated, and bit 1 indicates
6455  *  that the revision date should be propagated.
6456  *
6457  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6458  *
6459  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6460  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
6461  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
6462  * as part of the Perl standard distribution under the terms of the
6463  * GNU General Public License or the Perl Artistic License.  Copies
6464  * of each may be found in the Perl standard distribution.
6465  */
6466 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6467 int
6468 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6469 {
6470     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6471          rsa[NAM$C_MAXRSS], ubf[32256];
6472     unsigned long int i, sts, sts2;
6473     struct FAB fab_in, fab_out;
6474     struct RAB rab_in, rab_out;
6475     struct NAM nam;
6476     struct XABDAT xabdat;
6477     struct XABFHC xabfhc;
6478     struct XABRDT xabrdt;
6479     struct XABSUM xabsum;
6480
6481     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
6482         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6483       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6484       return 0;
6485     }
6486
6487     fab_in = cc$rms_fab;
6488     fab_in.fab$l_fna = vmsin;
6489     fab_in.fab$b_fns = strlen(vmsin);
6490     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6491     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6492     fab_in.fab$l_fop = FAB$M_SQO;
6493     fab_in.fab$l_nam =  &nam;
6494     fab_in.fab$l_xab = (void *) &xabdat;
6495
6496     nam = cc$rms_nam;
6497     nam.nam$l_rsa = rsa;
6498     nam.nam$b_rss = sizeof(rsa);
6499     nam.nam$l_esa = esa;
6500     nam.nam$b_ess = sizeof (esa);
6501     nam.nam$b_esl = nam.nam$b_rsl = 0;
6502
6503     xabdat = cc$rms_xabdat;        /* To get creation date */
6504     xabdat.xab$l_nxt = (void *) &xabfhc;
6505
6506     xabfhc = cc$rms_xabfhc;        /* To get record length */
6507     xabfhc.xab$l_nxt = (void *) &xabsum;
6508
6509     xabsum = cc$rms_xabsum;        /* To get key and area information */
6510
6511     if (!((sts = sys$open(&fab_in)) & 1)) {
6512       set_vaxc_errno(sts);
6513       switch (sts) {
6514         case RMS$_FNF: case RMS$_DNF:
6515           set_errno(ENOENT); break;
6516         case RMS$_DIR:
6517           set_errno(ENOTDIR); break;
6518         case RMS$_DEV:
6519           set_errno(ENODEV); break;
6520         case RMS$_SYN:
6521           set_errno(EINVAL); break;
6522         case RMS$_PRV:
6523           set_errno(EACCES); break;
6524         default:
6525           set_errno(EVMSERR);
6526       }
6527       return 0;
6528     }
6529
6530     fab_out = fab_in;
6531     fab_out.fab$w_ifi = 0;
6532     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6533     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6534     fab_out.fab$l_fop = FAB$M_SQO;
6535     fab_out.fab$l_fna = vmsout;
6536     fab_out.fab$b_fns = strlen(vmsout);
6537     fab_out.fab$l_dna = nam.nam$l_name;
6538     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6539
6540     if (preserve_dates == 0) {  /* Act like DCL COPY */
6541       nam.nam$b_nop = NAM$M_SYNCHK;
6542       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
6543       if (!((sts = sys$parse(&fab_out)) & 1)) {
6544         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6545         set_vaxc_errno(sts);
6546         return 0;
6547       }
6548       fab_out.fab$l_xab = (void *) &xabdat;
6549       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6550     }
6551     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
6552     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
6553       preserve_dates =0;      /* bitmask from this point forward   */
6554
6555     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6556     if (!((sts = sys$create(&fab_out)) & 1)) {
6557       set_vaxc_errno(sts);
6558       switch (sts) {
6559         case RMS$_DNF:
6560           set_errno(ENOENT); break;
6561         case RMS$_DIR:
6562           set_errno(ENOTDIR); break;
6563         case RMS$_DEV:
6564           set_errno(ENODEV); break;
6565         case RMS$_SYN:
6566           set_errno(EINVAL); break;
6567         case RMS$_PRV:
6568           set_errno(EACCES); break;
6569         default:
6570           set_errno(EVMSERR);
6571       }
6572       return 0;
6573     }
6574     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
6575     if (preserve_dates & 2) {
6576       /* sys$close() will process xabrdt, not xabdat */
6577       xabrdt = cc$rms_xabrdt;
6578 #ifndef __GNUC__
6579       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6580 #else
6581       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6582        * is unsigned long[2], while DECC & VAXC use a struct */
6583       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6584 #endif
6585       fab_out.fab$l_xab = (void *) &xabrdt;
6586     }
6587
6588     rab_in = cc$rms_rab;
6589     rab_in.rab$l_fab = &fab_in;
6590     rab_in.rab$l_rop = RAB$M_BIO;
6591     rab_in.rab$l_ubf = ubf;
6592     rab_in.rab$w_usz = sizeof ubf;
6593     if (!((sts = sys$connect(&rab_in)) & 1)) {
6594       sys$close(&fab_in); sys$close(&fab_out);
6595       set_errno(EVMSERR); set_vaxc_errno(sts);
6596       return 0;
6597     }
6598
6599     rab_out = cc$rms_rab;
6600     rab_out.rab$l_fab = &fab_out;
6601     rab_out.rab$l_rbf = ubf;
6602     if (!((sts = sys$connect(&rab_out)) & 1)) {
6603       sys$close(&fab_in); sys$close(&fab_out);
6604       set_errno(EVMSERR); set_vaxc_errno(sts);
6605       return 0;
6606     }
6607
6608     while ((sts = sys$read(&rab_in))) {  /* always true  */
6609       if (sts == RMS$_EOF) break;
6610       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6611       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6612         sys$close(&fab_in); sys$close(&fab_out);
6613         set_errno(EVMSERR); set_vaxc_errno(sts);
6614         return 0;
6615       }
6616     }
6617
6618     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
6619     sys$close(&fab_in);  sys$close(&fab_out);
6620     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6621     if (!(sts & 1)) {
6622       set_errno(EVMSERR); set_vaxc_errno(sts);
6623       return 0;
6624     }
6625
6626     return 1;
6627
6628 }  /* end of rmscopy() */
6629 /*}}}*/
6630
6631
6632 /***  The following glue provides 'hooks' to make some of the routines
6633  * from this file available from Perl.  These routines are sufficiently
6634  * basic, and are required sufficiently early in the build process,
6635  * that's it's nice to have them available to miniperl as well as the
6636  * full Perl, so they're set up here instead of in an extension.  The
6637  * Perl code which handles importation of these names into a given
6638  * package lives in [.VMS]Filespec.pm in @INC.
6639  */
6640
6641 void
6642 rmsexpand_fromperl(pTHX_ CV *cv)
6643 {
6644   dXSARGS;
6645   char *fspec, *defspec = NULL, *rslt;
6646   STRLEN n_a;
6647
6648   if (!items || items > 2)
6649     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6650   fspec = SvPV(ST(0),n_a);
6651   if (!fspec || !*fspec) XSRETURN_UNDEF;
6652   if (items == 2) defspec = SvPV(ST(1),n_a);
6653
6654   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6655   ST(0) = sv_newmortal();
6656   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6657   XSRETURN(1);
6658 }
6659
6660 void
6661 vmsify_fromperl(pTHX_ CV *cv)
6662 {
6663   dXSARGS;
6664   char *vmsified;
6665   STRLEN n_a;
6666
6667   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6668   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6669   ST(0) = sv_newmortal();
6670   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6671   XSRETURN(1);
6672 }
6673
6674 void
6675 unixify_fromperl(pTHX_ CV *cv)
6676 {
6677   dXSARGS;
6678   char *unixified;
6679   STRLEN n_a;
6680
6681   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6682   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6683   ST(0) = sv_newmortal();
6684   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6685   XSRETURN(1);
6686 }
6687
6688 void
6689 fileify_fromperl(pTHX_ CV *cv)
6690 {
6691   dXSARGS;
6692   char *fileified;
6693   STRLEN n_a;
6694
6695   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6696   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6697   ST(0) = sv_newmortal();
6698   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6699   XSRETURN(1);
6700 }
6701
6702 void
6703 pathify_fromperl(pTHX_ CV *cv)
6704 {
6705   dXSARGS;
6706   char *pathified;
6707   STRLEN n_a;
6708
6709   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6710   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6711   ST(0) = sv_newmortal();
6712   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6713   XSRETURN(1);
6714 }
6715
6716 void
6717 vmspath_fromperl(pTHX_ CV *cv)
6718 {
6719   dXSARGS;
6720   char *vmspath;
6721   STRLEN n_a;
6722
6723   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6724   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6725   ST(0) = sv_newmortal();
6726   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6727   XSRETURN(1);
6728 }
6729
6730 void
6731 unixpath_fromperl(pTHX_ CV *cv)
6732 {
6733   dXSARGS;
6734   char *unixpath;
6735   STRLEN n_a;
6736
6737   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6738   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6739   ST(0) = sv_newmortal();
6740   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6741   XSRETURN(1);
6742 }
6743
6744 void
6745 candelete_fromperl(pTHX_ CV *cv)
6746 {
6747   dXSARGS;
6748   char fspec[NAM$C_MAXRSS+1], *fsp;
6749   SV *mysv;
6750   IO *io;
6751   STRLEN n_a;
6752
6753   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6754
6755   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6756   if (SvTYPE(mysv) == SVt_PVGV) {
6757     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
6758       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6759       ST(0) = &PL_sv_no;
6760       XSRETURN(1);
6761     }
6762     fsp = fspec;
6763   }
6764   else {
6765     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6766       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6767       ST(0) = &PL_sv_no;
6768       XSRETURN(1);
6769     }
6770   }
6771
6772   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6773   XSRETURN(1);
6774 }
6775
6776 void
6777 rmscopy_fromperl(pTHX_ CV *cv)
6778 {
6779   dXSARGS;
6780   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6781   int date_flag;
6782   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6783                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6784   unsigned long int sts;
6785   SV *mysv;
6786   IO *io;
6787   STRLEN n_a;
6788
6789   if (items < 2 || items > 3)
6790     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6791
6792   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6793   if (SvTYPE(mysv) == SVt_PVGV) {
6794     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
6795       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6796       ST(0) = &PL_sv_no;
6797       XSRETURN(1);
6798     }
6799     inp = inspec;
6800   }
6801   else {
6802     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6803       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6804       ST(0) = &PL_sv_no;
6805       XSRETURN(1);
6806     }
6807   }
6808   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6809   if (SvTYPE(mysv) == SVt_PVGV) {
6810     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
6811       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6812       ST(0) = &PL_sv_no;
6813       XSRETURN(1);
6814     }
6815     outp = outspec;
6816   }
6817   else {
6818     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6819       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6820       ST(0) = &PL_sv_no;
6821       XSRETURN(1);
6822     }
6823   }
6824   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6825
6826   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6827   XSRETURN(1);
6828 }
6829
6830
6831 void
6832 mod2fname(pTHX_ CV *cv)
6833 {
6834   dXSARGS;
6835   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6836        workbuff[NAM$C_MAXRSS*1 + 1];
6837   int total_namelen = 3, counter, num_entries;
6838   /* ODS-5 ups this, but we want to be consistent, so... */
6839   int max_name_len = 39;
6840   AV *in_array = (AV *)SvRV(ST(0));
6841
6842   num_entries = av_len(in_array);
6843
6844   /* All the names start with PL_. */
6845   strcpy(ultimate_name, "PL_");
6846
6847   /* Clean up our working buffer */
6848   Zero(work_name, sizeof(work_name), char);
6849
6850   /* Run through the entries and build up a working name */
6851   for(counter = 0; counter <= num_entries; counter++) {
6852     /* If it's not the first name then tack on a __ */
6853     if (counter) {
6854       strcat(work_name, "__");
6855     }
6856     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
6857                            PL_na));
6858   }
6859
6860   /* Check to see if we actually have to bother...*/
6861   if (strlen(work_name) + 3 <= max_name_len) {
6862     strcat(ultimate_name, work_name);
6863   } else {
6864     /* It's too darned big, so we need to go strip. We use the same */
6865     /* algorithm as xsubpp does. First, strip out doubled __ */
6866     char *source, *dest, last;
6867     dest = workbuff;
6868     last = 0;
6869     for (source = work_name; *source; source++) {
6870       if (last == *source && last == '_') {
6871         continue;
6872       }
6873       *dest++ = *source;
6874       last = *source;
6875     }
6876     /* Go put it back */
6877     strcpy(work_name, workbuff);
6878     /* Is it still too big? */
6879     if (strlen(work_name) + 3 > max_name_len) {
6880       /* Strip duplicate letters */
6881       last = 0;
6882       dest = workbuff;
6883       for (source = work_name; *source; source++) {
6884         if (last == toupper(*source)) {
6885         continue;
6886         }
6887         *dest++ = *source;
6888         last = toupper(*source);
6889       }
6890       strcpy(work_name, workbuff);
6891     }
6892
6893     /* Is it *still* too big? */
6894     if (strlen(work_name) + 3 > max_name_len) {
6895       /* Too bad, we truncate */
6896       work_name[max_name_len - 2] = 0;
6897     }
6898     strcat(ultimate_name, work_name);
6899   }
6900
6901   /* Okay, return it */
6902   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
6903   XSRETURN(1);
6904 }
6905
6906 void
6907 init_os_extras()
6908 {
6909   dTHX;
6910   char* file = __FILE__;
6911   char temp_buff[512];
6912   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
6913     no_translate_barewords = TRUE;
6914   } else {
6915     no_translate_barewords = FALSE;
6916   }
6917
6918   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
6919   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
6920   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
6921   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
6922   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
6923   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
6924   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
6925   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
6926   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
6927   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
6928
6929   store_pipelocs(aTHX);
6930
6931   return;
6932 }
6933
6934 /*  End of vms.c */