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