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