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