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