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