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