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 **newargv, **oldargv;
4453     oldargv = *argvp;
4454     New(1320,newargv,(*argcp)+2,char *);
4455     newargv[0] = oldargv[0];
4456     New(1320,newargv[1],3,char);
4457     strcpy(newargv[1], "-T");
4458     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
4459     (*argcp)++;
4460     newargv[*argcp] = NULL;
4461     /* We orphan the old argv, since we don't know where it's come from,
4462      * so we don't know how to free it.
4463      */
4464     *argvp = newargv;
4465   }
4466   else {  /* Did user explicitly request tainting? */
4467     int i;
4468     char *cp, **av = *argvp;
4469     for (i = 1; i < *argcp; i++) {
4470       if (*av[i] != '-') break;
4471       for (cp = av[i]+1; *cp; cp++) {
4472         if (*cp == 'T') { will_taint = 1; break; }
4473         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4474                   strchr("DFIiMmx",*cp)) break;
4475       }
4476       if (will_taint) break;
4477     }
4478   }
4479
4480   for (tabidx = 0;
4481        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4482        tabidx++) {
4483     if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4484     else if (tabidx >= tabct) {
4485       tabct += 8;
4486       Renew(tabvec,tabct,struct dsc$descriptor_s *);
4487     }
4488     New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4489     tabvec[tabidx]->dsc$w_length  = 0;
4490     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
4491     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
4492     tabvec[tabidx]->dsc$a_pointer = NULL;
4493     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4494   }
4495   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4496
4497   getredirection(argcp,argvp);
4498   return;
4499 }
4500 /*}}}*/
4501
4502
4503 /* trim_unixpath()
4504  * Trim Unix-style prefix off filespec, so it looks like what a shell
4505  * glob expansion would return (i.e. from specified prefix on, not
4506  * full path).  Note that returned filespec is Unix-style, regardless
4507  * of whether input filespec was VMS-style or Unix-style.
4508  *
4509  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4510  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
4511  * vector of options; at present, only bit 0 is used, and if set tells
4512  * trim unixpath to try the current default directory as a prefix when
4513  * presented with a possibly ambiguous ... wildcard.
4514  *
4515  * Returns !=0 on success, with trimmed filespec replacing contents of
4516  * fspec, and 0 on failure, with contents of fpsec unchanged.
4517  */
4518 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4519 int
4520 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4521 {
4522   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4523        *template, *base, *end, *cp1, *cp2;
4524   register int tmplen, reslen = 0, dirs = 0;
4525
4526   if (!wildspec || !fspec) return 0;
4527   if (strpbrk(wildspec,"]>:") != NULL) {
4528     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4529     else template = unixwild;
4530   }
4531   else template = wildspec;
4532   if (strpbrk(fspec,"]>:") != NULL) {
4533     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4534     else base = unixified;
4535     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4536      * check to see that final result fits into (isn't longer than) fspec */
4537     reslen = strlen(fspec);
4538   }
4539   else base = fspec;
4540
4541   /* No prefix or absolute path on wildcard, so nothing to remove */
4542   if (!*template || *template == '/') {
4543     if (base == fspec) return 1;
4544     tmplen = strlen(unixified);
4545     if (tmplen > reslen) return 0;  /* not enough space */
4546     /* Copy unixified resultant, including trailing NUL */
4547     memmove(fspec,unixified,tmplen+1);
4548     return 1;
4549   }
4550
4551   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
4552   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4553     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4554     for (cp1 = end ;cp1 >= base; cp1--)
4555       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4556         { cp1++; break; }
4557     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4558     return 1;
4559   }
4560   else {
4561     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4562     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4563     int ells = 1, totells, segdirs, match;
4564     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4565                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4566
4567     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4568     totells = ells;
4569     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4570     if (ellipsis == template && opts & 1) {
4571       /* Template begins with an ellipsis.  Since we can't tell how many
4572        * directory names at the front of the resultant to keep for an
4573        * arbitrary starting point, we arbitrarily choose the current
4574        * default directory as a starting point.  If it's there as a prefix,
4575        * clip it off.  If not, fall through and act as if the leading
4576        * ellipsis weren't there (i.e. return shortest possible path that
4577        * could match template).
4578        */
4579       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4580       for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4581         if (_tolower(*cp1) != _tolower(*cp2)) break;
4582       segdirs = dirs - totells;  /* Min # of dirs we must have left */
4583       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4584       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4585         memcpy(fspec,cp2+1,end - cp2);
4586         return 1;
4587       }
4588     }
4589     /* First off, back up over constant elements at end of path */
4590     if (dirs) {
4591       for (front = end ; front >= base; front--)
4592          if (*front == '/' && !dirs--) { front++; break; }
4593     }
4594     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4595          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
4596     if (cp1 != '\0') return 0;  /* Path too long. */
4597     lcend = cp2;
4598     *cp2 = '\0';  /* Pick up with memcpy later */
4599     lcfront = lcres + (front - base);
4600     /* Now skip over each ellipsis and try to match the path in front of it. */
4601     while (ells--) {
4602       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4603         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
4604             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
4605       if (cp1 < template) break; /* template started with an ellipsis */
4606       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4607         ellipsis = cp1; continue;
4608       }
4609       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4610       nextell = cp1;
4611       for (segdirs = 0, cp2 = tpl;
4612            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4613            cp1++, cp2++) {
4614          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4615          else *cp2 = _tolower(*cp1);  /* else lowercase for match */
4616          if (*cp2 == '/') segdirs++;
4617       }
4618       if (cp1 != ellipsis - 1) return 0; /* Path too long */
4619       /* Back up at least as many dirs as in template before matching */
4620       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4621         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4622       for (match = 0; cp1 > lcres;) {
4623         resdsc.dsc$a_pointer = cp1;
4624         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4625           match++;
4626           if (match == 1) lcfront = cp1;
4627         }
4628         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4629       }
4630       if (!match) return 0;  /* Can't find prefix ??? */
4631       if (match > 1 && opts & 1) {
4632         /* This ... wildcard could cover more than one set of dirs (i.e.
4633          * a set of similar dir names is repeated).  If the template
4634          * contains more than 1 ..., upstream elements could resolve the
4635          * ambiguity, but it's not worth a full backtracking setup here.
4636          * As a quick heuristic, clip off the current default directory
4637          * if it's present to find the trimmed spec, else use the
4638          * shortest string that this ... could cover.
4639          */
4640         char def[NAM$C_MAXRSS+1], *st;
4641
4642         if (getcwd(def, sizeof def,0) == NULL) return 0;
4643         for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4644           if (_tolower(*cp1) != _tolower(*cp2)) break;
4645         segdirs = dirs - totells;  /* Min # of dirs we must have left */
4646         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4647         if (*cp1 == '\0' && *cp2 == '/') {
4648           memcpy(fspec,cp2+1,end - cp2);
4649           return 1;
4650         }
4651         /* Nope -- stick with lcfront from above and keep going. */
4652       }
4653     }
4654     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4655     return 1;
4656     ellipsis = nextell;
4657   }
4658
4659 }  /* end of trim_unixpath() */
4660 /*}}}*/
4661
4662
4663 /*
4664  *  VMS readdir() routines.
4665  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4666  *
4667  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
4668  *  Minor modifications to original routines.
4669  */
4670
4671     /* Number of elements in vms_versions array */
4672 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
4673
4674 /*
4675  *  Open a directory, return a handle for later use.
4676  */
4677 /*{{{ DIR *opendir(char*name) */
4678 DIR *
4679 Perl_opendir(pTHX_ char *name)
4680 {
4681     DIR *dd;
4682     char dir[NAM$C_MAXRSS+1];
4683     Stat_t sb;
4684
4685     if (do_tovmspath(name,dir,0) == NULL) {
4686       return NULL;
4687     }
4688     /* Check access before stat; otherwise stat does not
4689      * accurately report whether it's a directory.
4690      */
4691     if (!cando_by_name(S_IRUSR,0,dir)) {
4692       /* cando_by_name has already set errno */
4693       return NULL;
4694     }
4695     if (flex_stat(dir,&sb) == -1) return NULL;
4696     if (!S_ISDIR(sb.st_mode)) {
4697       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
4698       return NULL;
4699     }
4700     /* Get memory for the handle, and the pattern. */
4701     New(1306,dd,1,DIR);
4702     New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4703
4704     /* Fill in the fields; mainly playing with the descriptor. */
4705     (void)sprintf(dd->pattern, "%s*.*",dir);
4706     dd->context = 0;
4707     dd->count = 0;
4708     dd->vms_wantversions = 0;
4709     dd->pat.dsc$a_pointer = dd->pattern;
4710     dd->pat.dsc$w_length = strlen(dd->pattern);
4711     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4712     dd->pat.dsc$b_class = DSC$K_CLASS_S;
4713
4714     return dd;
4715 }  /* end of opendir() */
4716 /*}}}*/
4717
4718 /*
4719  *  Set the flag to indicate we want versions or not.
4720  */
4721 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4722 void
4723 vmsreaddirversions(DIR *dd, int flag)
4724 {
4725     dd->vms_wantversions = flag;
4726 }
4727 /*}}}*/
4728
4729 /*
4730  *  Free up an opened directory.
4731  */
4732 /*{{{ void closedir(DIR *dd)*/
4733 void
4734 closedir(DIR *dd)
4735 {
4736     (void)lib$find_file_end(&dd->context);
4737     Safefree(dd->pattern);
4738     Safefree((char *)dd);
4739 }
4740 /*}}}*/
4741
4742 /*
4743  *  Collect all the version numbers for the current file.
4744  */
4745 static void
4746 collectversions(pTHX_ DIR *dd)
4747 {
4748     struct dsc$descriptor_s     pat;
4749     struct dsc$descriptor_s     res;
4750     struct dirent *e;
4751     char *p, *text, buff[sizeof dd->entry.d_name];
4752     int i;
4753     unsigned long context, tmpsts;
4754
4755     /* Convenient shorthand. */
4756     e = &dd->entry;
4757
4758     /* Add the version wildcard, ignoring the "*.*" put on before */
4759     i = strlen(dd->pattern);
4760     New(1308,text,i + e->d_namlen + 3,char);
4761     (void)strcpy(text, dd->pattern);
4762     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4763
4764     /* Set up the pattern descriptor. */
4765     pat.dsc$a_pointer = text;
4766     pat.dsc$w_length = i + e->d_namlen - 1;
4767     pat.dsc$b_dtype = DSC$K_DTYPE_T;
4768     pat.dsc$b_class = DSC$K_CLASS_S;
4769
4770     /* Set up result descriptor. */
4771     res.dsc$a_pointer = buff;
4772     res.dsc$w_length = sizeof buff - 2;
4773     res.dsc$b_dtype = DSC$K_DTYPE_T;
4774     res.dsc$b_class = DSC$K_CLASS_S;
4775
4776     /* Read files, collecting versions. */
4777     for (context = 0, e->vms_verscount = 0;
4778          e->vms_verscount < VERSIZE(e);
4779          e->vms_verscount++) {
4780         tmpsts = lib$find_file(&pat, &res, &context);
4781         if (tmpsts == RMS$_NMF || context == 0) break;
4782         _ckvmssts(tmpsts);
4783         buff[sizeof buff - 1] = '\0';
4784         if ((p = strchr(buff, ';')))
4785             e->vms_versions[e->vms_verscount] = atoi(p + 1);
4786         else
4787             e->vms_versions[e->vms_verscount] = -1;
4788     }
4789
4790     _ckvmssts(lib$find_file_end(&context));
4791     Safefree(text);
4792
4793 }  /* end of collectversions() */
4794
4795 /*
4796  *  Read the next entry from the directory.
4797  */
4798 /*{{{ struct dirent *readdir(DIR *dd)*/
4799 struct dirent *
4800 Perl_readdir(pTHX_ DIR *dd)
4801 {
4802     struct dsc$descriptor_s     res;
4803     char *p, buff[sizeof dd->entry.d_name];
4804     unsigned long int tmpsts;
4805
4806     /* Set up result descriptor, and get next file. */
4807     res.dsc$a_pointer = buff;
4808     res.dsc$w_length = sizeof buff - 2;
4809     res.dsc$b_dtype = DSC$K_DTYPE_T;
4810     res.dsc$b_class = DSC$K_CLASS_S;
4811     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4812     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
4813     if (!(tmpsts & 1)) {
4814       set_vaxc_errno(tmpsts);
4815       switch (tmpsts) {
4816         case RMS$_PRV:
4817           set_errno(EACCES); break;
4818         case RMS$_DEV:
4819           set_errno(ENODEV); break;
4820         case RMS$_DIR:
4821           set_errno(ENOTDIR); break;
4822         case RMS$_FNF: case RMS$_DNF:
4823           set_errno(ENOENT); break;
4824         default:
4825           set_errno(EVMSERR);
4826       }
4827       return NULL;
4828     }
4829     dd->count++;
4830     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4831     buff[sizeof buff - 1] = '\0';
4832     for (p = buff; *p; p++) *p = _tolower(*p);
4833     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
4834     *p = '\0';
4835
4836     /* Skip any directory component and just copy the name. */
4837     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4838     else (void)strcpy(dd->entry.d_name, buff);
4839
4840     /* Clobber the version. */
4841     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4842
4843     dd->entry.d_namlen = strlen(dd->entry.d_name);
4844     dd->entry.vms_verscount = 0;
4845     if (dd->vms_wantversions) collectversions(aTHX_ dd);
4846     return &dd->entry;
4847
4848 }  /* end of readdir() */
4849 /*}}}*/
4850
4851 /*
4852  *  Return something that can be used in a seekdir later.
4853  */
4854 /*{{{ long telldir(DIR *dd)*/
4855 long
4856 telldir(DIR *dd)
4857 {
4858     return dd->count;
4859 }
4860 /*}}}*/
4861
4862 /*
4863  *  Return to a spot where we used to be.  Brute force.
4864  */
4865 /*{{{ void seekdir(DIR *dd,long count)*/
4866 void
4867 Perl_seekdir(pTHX_ DIR *dd, long count)
4868 {
4869     int vms_wantversions;
4870
4871     /* If we haven't done anything yet... */
4872     if (dd->count == 0)
4873         return;
4874
4875     /* Remember some state, and clear it. */
4876     vms_wantversions = dd->vms_wantversions;
4877     dd->vms_wantversions = 0;
4878     _ckvmssts(lib$find_file_end(&dd->context));
4879     dd->context = 0;
4880
4881     /* The increment is in readdir(). */
4882     for (dd->count = 0; dd->count < count; )
4883         (void)readdir(dd);
4884
4885     dd->vms_wantversions = vms_wantversions;
4886
4887 }  /* end of seekdir() */
4888 /*}}}*/
4889
4890 /* VMS subprocess management
4891  *
4892  * my_vfork() - just a vfork(), after setting a flag to record that
4893  * the current script is trying a Unix-style fork/exec.
4894  *
4895  * vms_do_aexec() and vms_do_exec() are called in response to the
4896  * perl 'exec' function.  If this follows a vfork call, then they
4897  * call out the the regular perl routines in doio.c which do an
4898  * execvp (for those who really want to try this under VMS).
4899  * Otherwise, they do exactly what the perl docs say exec should
4900  * do - terminate the current script and invoke a new command
4901  * (See below for notes on command syntax.)
4902  *
4903  * do_aspawn() and do_spawn() implement the VMS side of the perl
4904  * 'system' function.
4905  *
4906  * Note on command arguments to perl 'exec' and 'system': When handled
4907  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4908  * are concatenated to form a DCL command string.  If the first arg
4909  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4910  * the the command string is handed off to DCL directly.  Otherwise,
4911  * the first token of the command is taken as the filespec of an image
4912  * to run.  The filespec is expanded using a default type of '.EXE' and
4913  * the process defaults for device, directory, etc., and if found, the resultant
4914  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4915  * the command string as parameters.  This is perhaps a bit complicated,
4916  * but I hope it will form a happy medium between what VMS folks expect
4917  * from lib$spawn and what Unix folks expect from exec.
4918  */
4919
4920 static int vfork_called;
4921
4922 /*{{{int my_vfork()*/
4923 int
4924 my_vfork()
4925 {
4926   vfork_called++;
4927   return vfork();
4928 }
4929 /*}}}*/
4930
4931
4932 static void
4933 vms_execfree(struct dsc$descriptor_s *vmscmd)
4934 {
4935   if (vmscmd) {
4936       if (vmscmd->dsc$a_pointer) {
4937           Safefree(vmscmd->dsc$a_pointer);
4938       }
4939       Safefree(vmscmd);
4940   }
4941 }
4942
4943 static char *
4944 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4945 {
4946   char *junk, *tmps = Nullch;
4947   register size_t cmdlen = 0;
4948   size_t rlen;
4949   register SV **idx;
4950   STRLEN n_a;
4951
4952   idx = mark;
4953   if (really) {
4954     tmps = SvPV(really,rlen);
4955     if (*tmps) {
4956       cmdlen += rlen + 1;
4957       idx++;
4958     }
4959   }
4960
4961   for (idx++; idx <= sp; idx++) {
4962     if (*idx) {
4963       junk = SvPVx(*idx,rlen);
4964       cmdlen += rlen ? rlen + 1 : 0;
4965     }
4966   }
4967   New(401,PL_Cmd,cmdlen+1,char);
4968
4969   if (tmps && *tmps) {
4970     strcpy(PL_Cmd,tmps);
4971     mark++;
4972   }
4973   else *PL_Cmd = '\0';
4974   while (++mark <= sp) {
4975     if (*mark) {
4976       char *s = SvPVx(*mark,n_a);
4977       if (!*s) continue;
4978       if (*PL_Cmd) strcat(PL_Cmd," ");
4979       strcat(PL_Cmd,s);
4980     }
4981   }
4982   return PL_Cmd;
4983
4984 }  /* end of setup_argstr() */
4985
4986
4987 static unsigned long int
4988 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
4989                    struct dsc$descriptor_s **pvmscmd)
4990 {
4991   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4992   $DESCRIPTOR(defdsc,".EXE");
4993   $DESCRIPTOR(defdsc2,".");
4994   $DESCRIPTOR(resdsc,resspec);
4995   struct dsc$descriptor_s *vmscmd;
4996   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4997   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4998   register char *s, *rest, *cp, *wordbreak;
4999   register int isdcl;
5000
5001   New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5002   vmscmd->dsc$a_pointer = NULL;
5003   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
5004   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
5005   vmscmd->dsc$w_length = 0;
5006   if (pvmscmd) *pvmscmd = vmscmd;
5007
5008   if (suggest_quote) *suggest_quote = 0;
5009
5010   if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5011     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
5012   s = cmd;
5013   while (*s && isspace(*s)) s++;
5014
5015   if (*s == '@' || *s == '$') {
5016     vmsspec[0] = *s;  rest = s + 1;
5017     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5018   }
5019   else { cp = vmsspec; rest = s; }
5020   if (*rest == '.' || *rest == '/') {
5021     char *cp2;
5022     for (cp2 = resspec;
5023          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5024          rest++, cp2++) *cp2 = *rest;
5025     *cp2 = '\0';
5026     if (do_tovmsspec(resspec,cp,0)) {
5027       s = vmsspec;
5028       if (*rest) {
5029         for (cp2 = vmsspec + strlen(vmsspec);
5030              *rest && cp2 - vmsspec < sizeof vmsspec;
5031              rest++, cp2++) *cp2 = *rest;
5032         *cp2 = '\0';
5033       }
5034     }
5035   }
5036   /* Intuit whether verb (first word of cmd) is a DCL command:
5037    *   - if first nonspace char is '@', it's a DCL indirection
5038    * otherwise
5039    *   - if verb contains a filespec separator, it's not a DCL command
5040    *   - if it doesn't, caller tells us whether to default to a DCL
5041    *     command, or to a local image unless told it's DCL (by leading '$')
5042    */
5043   if (*s == '@') {
5044       isdcl = 1;
5045       if (suggest_quote) *suggest_quote = 1;
5046   } else {
5047     register char *filespec = strpbrk(s,":<[.;");
5048     rest = wordbreak = strpbrk(s," \"\t/");
5049     if (!wordbreak) wordbreak = s + strlen(s);
5050     if (*s == '$') check_img = 0;
5051     if (filespec && (filespec < wordbreak)) isdcl = 0;
5052     else isdcl = !check_img;
5053   }
5054
5055   if (!isdcl) {
5056     imgdsc.dsc$a_pointer = s;
5057     imgdsc.dsc$w_length = wordbreak - s;
5058     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5059     if (!(retsts&1)) {
5060         _ckvmssts(lib$find_file_end(&cxt));
5061         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5062     if (!(retsts & 1) && *s == '$') {
5063           _ckvmssts(lib$find_file_end(&cxt));
5064       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5065       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5066           if (!(retsts&1)) {
5067       _ckvmssts(lib$find_file_end(&cxt));
5068             retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5069           }
5070     }
5071     }
5072     _ckvmssts(lib$find_file_end(&cxt));
5073
5074     if (retsts & 1) {
5075       FILE *fp;
5076       s = resspec;
5077       while (*s && !isspace(*s)) s++;
5078       *s = '\0';
5079
5080       /* check that it's really not DCL with no file extension */
5081       fp = fopen(resspec,"r","ctx=bin,shr=get");
5082       if (fp) {
5083         char b[4] = {0,0,0,0};
5084         read(fileno(fp),b,4);
5085         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5086         fclose(fp);
5087       }
5088       if (check_img && isdcl) return RMS$_FNF;
5089
5090       if (cando_by_name(S_IXUSR,0,resspec)) {
5091         New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5092         if (!isdcl) {
5093             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5094             if (suggest_quote) *suggest_quote = 1;
5095         } else {
5096             strcpy(vmscmd->dsc$a_pointer,"@");
5097             if (suggest_quote) *suggest_quote = 1;
5098         }
5099         strcat(vmscmd->dsc$a_pointer,resspec);
5100         if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5101         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5102         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5103       }
5104       else retsts = RMS$_PRV;
5105     }
5106   }
5107   /* It's either a DCL command or we couldn't find a suitable image */
5108   vmscmd->dsc$w_length = strlen(cmd);
5109 /*  if (cmd == PL_Cmd) {
5110       vmscmd->dsc$a_pointer = PL_Cmd;
5111       if (suggest_quote) *suggest_quote = 1;
5112   }
5113   else  */
5114       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5115
5116   /* check if it's a symbol (for quoting purposes) */
5117   if (suggest_quote && !*suggest_quote) {
5118     int iss;
5119     char equiv[LNM$C_NAMLENGTH];
5120     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5121     eqvdsc.dsc$a_pointer = equiv;
5122
5123     iss = lib$get_symbol(vmscmd,&eqvdsc);
5124     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5125   }
5126   if (!(retsts & 1)) {
5127     /* just hand off status values likely to be due to user error */
5128     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5129         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5130        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5131     else { _ckvmssts(retsts); }
5132   }
5133
5134   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5135
5136 }  /* end of setup_cmddsc() */
5137
5138
5139 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5140 bool
5141 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5142 {
5143   if (sp > mark) {
5144     if (vfork_called) {           /* this follows a vfork - act Unixish */
5145       vfork_called--;
5146       if (vfork_called < 0) {
5147         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5148         vfork_called = 0;
5149       }
5150       else return do_aexec(really,mark,sp);
5151     }
5152                                            /* no vfork - act VMSish */
5153     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5154
5155   }
5156
5157   return FALSE;
5158 }  /* end of vms_do_aexec() */
5159 /*}}}*/
5160
5161 /* {{{bool vms_do_exec(char *cmd) */
5162 bool
5163 Perl_vms_do_exec(pTHX_ char *cmd)
5164 {
5165   struct dsc$descriptor_s *vmscmd;
5166
5167   if (vfork_called) {             /* this follows a vfork - act Unixish */
5168     vfork_called--;
5169     if (vfork_called < 0) {
5170       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5171       vfork_called = 0;
5172     }
5173     else return do_exec(cmd);
5174   }
5175
5176   {                               /* no vfork - act VMSish */
5177     unsigned long int retsts;
5178
5179     TAINT_ENV();
5180     TAINT_PROPER("exec");
5181     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5182       retsts = lib$do_command(vmscmd);
5183
5184     switch (retsts) {
5185       case RMS$_FNF: case RMS$_DNF:
5186         set_errno(ENOENT); break;
5187       case RMS$_DIR:
5188         set_errno(ENOTDIR); break;
5189       case RMS$_DEV:
5190         set_errno(ENODEV); break;
5191       case RMS$_PRV:
5192         set_errno(EACCES); break;
5193       case RMS$_SYN:
5194         set_errno(EINVAL); break;
5195       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5196         set_errno(E2BIG); break;
5197       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5198         _ckvmssts(retsts); /* fall through */
5199       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5200         set_errno(EVMSERR);
5201     }
5202     set_vaxc_errno(retsts);
5203     if (ckWARN(WARN_EXEC)) {
5204       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5205              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5206     }
5207     vms_execfree(vmscmd);
5208   }
5209
5210   return FALSE;
5211
5212 }  /* end of vms_do_exec() */
5213 /*}}}*/
5214
5215 unsigned long int Perl_do_spawn(pTHX_ char *);
5216
5217 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5218 unsigned long int
5219 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5220 {
5221   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5222
5223   return SS$_ABORT;
5224 }  /* end of do_aspawn() */
5225 /*}}}*/
5226
5227 /* {{{unsigned long int do_spawn(char *cmd) */
5228 unsigned long int
5229 Perl_do_spawn(pTHX_ char *cmd)
5230 {
5231   unsigned long int sts, substs;
5232
5233   TAINT_ENV();
5234   TAINT_PROPER("spawn");
5235   if (!cmd || !*cmd) {
5236     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5237     if (!(sts & 1)) {
5238       switch (sts) {
5239         case RMS$_FNF:  case RMS$_DNF:
5240           set_errno(ENOENT); break;
5241         case RMS$_DIR:
5242           set_errno(ENOTDIR); break;
5243         case RMS$_DEV:
5244           set_errno(ENODEV); break;
5245         case RMS$_PRV:
5246           set_errno(EACCES); break;
5247         case RMS$_SYN:
5248           set_errno(EINVAL); break;
5249         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5250           set_errno(E2BIG); break;
5251         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5252           _ckvmssts(sts); /* fall through */
5253         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5254           set_errno(EVMSERR);
5255       }
5256       set_vaxc_errno(sts);
5257       if (ckWARN(WARN_EXEC)) {
5258         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5259                     Strerror(errno));
5260       }
5261     }
5262     sts = substs;
5263   }
5264   else {
5265     (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5266   }
5267   return sts;
5268 }  /* end of do_spawn() */
5269 /*}}}*/
5270
5271
5272 static unsigned int *sockflags, sockflagsize;
5273
5274 /*
5275  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5276  * routines found in some versions of the CRTL can't deal with sockets.
5277  * We don't shim the other file open routines since a socket isn't
5278  * likely to be opened by a name.
5279  */
5280 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5281 FILE *my_fdopen(int fd, const char *mode)
5282 {
5283   FILE *fp = fdopen(fd, (char *) mode);
5284
5285   if (fp) {
5286     unsigned int fdoff = fd / sizeof(unsigned int);
5287     struct stat sbuf; /* native stat; we don't need flex_stat */
5288     if (!sockflagsize || fdoff > sockflagsize) {
5289       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
5290       else           New  (1324,sockflags,fdoff+2,unsigned int);
5291       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5292       sockflagsize = fdoff + 2;
5293     }
5294     if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5295       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5296   }
5297   return fp;
5298
5299 }
5300 /*}}}*/
5301
5302
5303 /*
5304  * Clear the corresponding bit when the (possibly) socket stream is closed.
5305  * There still a small hole: we miss an implicit close which might occur
5306  * via freopen().  >> Todo
5307  */
5308 /*{{{ int my_fclose(FILE *fp)*/
5309 int my_fclose(FILE *fp) {
5310   if (fp) {
5311     unsigned int fd = fileno(fp);
5312     unsigned int fdoff = fd / sizeof(unsigned int);
5313
5314     if (sockflagsize && fdoff <= sockflagsize)
5315       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5316   }
5317   return fclose(fp);
5318 }
5319 /*}}}*/
5320
5321
5322 /*
5323  * A simple fwrite replacement which outputs itmsz*nitm chars without
5324  * introducing record boundaries every itmsz chars.
5325  * We are using fputs, which depends on a terminating null.  We may
5326  * well be writing binary data, so we need to accommodate not only
5327  * data with nulls sprinkled in the middle but also data with no null
5328  * byte at the end.
5329  */
5330 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5331 int
5332 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5333 {
5334   register char *cp, *end, *cpd, *data;
5335   register unsigned int fd = fileno(dest);
5336   register unsigned int fdoff = fd / sizeof(unsigned int);
5337   int retval;
5338   int bufsize = itmsz * nitm + 1;
5339
5340   if (fdoff < sockflagsize &&
5341       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5342     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5343     return nitm;
5344   }
5345
5346   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5347   memcpy( data, src, itmsz*nitm );
5348   data[itmsz*nitm] = '\0';
5349
5350   end = data + itmsz * nitm;
5351   retval = (int) nitm; /* on success return # items written */
5352
5353   cpd = data;
5354   while (cpd <= end) {
5355     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5356     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5357     if (cp < end)
5358       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5359     cpd = cp + 1;
5360   }
5361
5362   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5363   return retval;
5364
5365 }  /* end of my_fwrite() */
5366 /*}}}*/
5367
5368 /*{{{ int my_flush(FILE *fp)*/
5369 int
5370 Perl_my_flush(pTHX_ FILE *fp)
5371 {
5372     int res;
5373     if ((res = fflush(fp)) == 0 && fp) {
5374 #ifdef VMS_DO_SOCKETS
5375         Stat_t s;
5376         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5377 #endif
5378             res = fsync(fileno(fp));
5379     }
5380 /*
5381  * If the flush succeeded but set end-of-file, we need to clear
5382  * the error because our caller may check ferror().  BTW, this
5383  * probably means we just flushed an empty file.
5384  */
5385     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5386
5387     return res;
5388 }
5389 /*}}}*/
5390
5391 /*
5392  * Here are replacements for the following Unix routines in the VMS environment:
5393  *      getpwuid    Get information for a particular UIC or UID
5394  *      getpwnam    Get information for a named user
5395  *      getpwent    Get information for each user in the rights database
5396  *      setpwent    Reset search to the start of the rights database
5397  *      endpwent    Finish searching for users in the rights database
5398  *
5399  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5400  * (defined in pwd.h), which contains the following fields:-
5401  *      struct passwd {
5402  *              char        *pw_name;    Username (in lower case)
5403  *              char        *pw_passwd;  Hashed password
5404  *              unsigned int pw_uid;     UIC
5405  *              unsigned int pw_gid;     UIC group  number
5406  *              char        *pw_unixdir; Default device/directory (VMS-style)
5407  *              char        *pw_gecos;   Owner name
5408  *              char        *pw_dir;     Default device/directory (Unix-style)
5409  *              char        *pw_shell;   Default CLI name (eg. DCL)
5410  *      };
5411  * If the specified user does not exist, getpwuid and getpwnam return NULL.
5412  *
5413  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5414  * not the UIC member number (eg. what's returned by getuid()),
5415  * getpwuid() can accept either as input (if uid is specified, the caller's
5416  * UIC group is used), though it won't recognise gid=0.
5417  *
5418  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5419  * information about other users in your group or in other groups, respectively.
5420  * If the required privilege is not available, then these routines fill only
5421  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5422  * string).
5423  *
5424  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5425  */
5426
5427 /* sizes of various UAF record fields */
5428 #define UAI$S_USERNAME 12
5429 #define UAI$S_IDENT    31
5430 #define UAI$S_OWNER    31
5431 #define UAI$S_DEFDEV   31
5432 #define UAI$S_DEFDIR   63
5433 #define UAI$S_DEFCLI   31
5434 #define UAI$S_PWD       8
5435
5436 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
5437                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5438                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
5439
5440 static char __empty[]= "";
5441 static struct passwd __passwd_empty=
5442     {(char *) __empty, (char *) __empty, 0, 0,
5443      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5444 static int contxt= 0;
5445 static struct passwd __pwdcache;
5446 static char __pw_namecache[UAI$S_IDENT+1];
5447
5448 /*
5449  * This routine does most of the work extracting the user information.
5450  */
5451 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5452 {
5453     static struct {
5454         unsigned char length;
5455         char pw_gecos[UAI$S_OWNER+1];
5456     } owner;
5457     static union uicdef uic;
5458     static struct {
5459         unsigned char length;
5460         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5461     } defdev;
5462     static struct {
5463         unsigned char length;
5464         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5465     } defdir;
5466     static struct {
5467         unsigned char length;
5468         char pw_shell[UAI$S_DEFCLI+1];
5469     } defcli;
5470     static char pw_passwd[UAI$S_PWD+1];
5471
5472     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5473     struct dsc$descriptor_s name_desc;
5474     unsigned long int sts;
5475
5476     static struct itmlst_3 itmlst[]= {
5477         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
5478         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
5479         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
5480         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
5481         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
5482         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
5483         {0,                0,           NULL,    NULL}};
5484
5485     name_desc.dsc$w_length=  strlen(name);
5486     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5487     name_desc.dsc$b_class=   DSC$K_CLASS_S;
5488     name_desc.dsc$a_pointer= (char *) name;
5489
5490 /*  Note that sys$getuai returns many fields as counted strings. */
5491     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5492     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5493       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5494     }
5495     else { _ckvmssts(sts); }
5496     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
5497
5498     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
5499     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5500     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5501     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5502     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5503     owner.pw_gecos[lowner]=            '\0';
5504     defdev.pw_dir[ldefdev+ldefdir]= '\0';
5505     defcli.pw_shell[ldefcli]=          '\0';
5506     if (valid_uic(uic)) {
5507         pwd->pw_uid= uic.uic$l_uic;
5508         pwd->pw_gid= uic.uic$v_group;
5509     }
5510     else
5511       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5512     pwd->pw_passwd=  pw_passwd;
5513     pwd->pw_gecos=   owner.pw_gecos;
5514     pwd->pw_dir=     defdev.pw_dir;
5515     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5516     pwd->pw_shell=   defcli.pw_shell;
5517     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5518         int ldir;
5519         ldir= strlen(pwd->pw_unixdir) - 1;
5520         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5521     }
5522     else
5523         strcpy(pwd->pw_unixdir, pwd->pw_dir);
5524     __mystrtolower(pwd->pw_unixdir);
5525     return 1;
5526 }
5527
5528 /*
5529  * Get information for a named user.
5530 */
5531 /*{{{struct passwd *getpwnam(char *name)*/
5532 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5533 {
5534     struct dsc$descriptor_s name_desc;
5535     union uicdef uic;
5536     unsigned long int status, sts;
5537
5538     __pwdcache = __passwd_empty;
5539     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5540       /* We still may be able to determine pw_uid and pw_gid */
5541       name_desc.dsc$w_length=  strlen(name);
5542       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
5543       name_desc.dsc$b_class=   DSC$K_CLASS_S;
5544       name_desc.dsc$a_pointer= (char *) name;
5545       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5546         __pwdcache.pw_uid= uic.uic$l_uic;
5547         __pwdcache.pw_gid= uic.uic$v_group;
5548       }
5549       else {
5550         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5551           set_vaxc_errno(sts);
5552           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5553           return NULL;
5554         }
5555         else { _ckvmssts(sts); }
5556       }
5557     }
5558     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5559     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5560     __pwdcache.pw_name= __pw_namecache;
5561     return &__pwdcache;
5562 }  /* end of my_getpwnam() */
5563 /*}}}*/
5564
5565 /*
5566  * Get information for a particular UIC or UID.
5567  * Called by my_getpwent with uid=-1 to list all users.
5568 */
5569 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5570 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5571 {
5572     const $DESCRIPTOR(name_desc,__pw_namecache);
5573     unsigned short lname;
5574     union uicdef uic;
5575     unsigned long int status;
5576
5577     if (uid == (unsigned int) -1) {
5578       do {
5579         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5580         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5581           set_vaxc_errno(status);
5582           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5583           my_endpwent();
5584           return NULL;
5585         }
5586         else { _ckvmssts(status); }
5587       } while (!valid_uic (uic));
5588     }
5589     else {
5590       uic.uic$l_uic= uid;
5591       if (!uic.uic$v_group)
5592         uic.uic$v_group= PerlProc_getgid();
5593       if (valid_uic(uic))
5594         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5595       else status = SS$_IVIDENT;
5596       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5597           status == RMS$_PRV) {
5598         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5599         return NULL;
5600       }
5601       else { _ckvmssts(status); }
5602     }
5603     __pw_namecache[lname]= '\0';
5604     __mystrtolower(__pw_namecache);
5605
5606     __pwdcache = __passwd_empty;
5607     __pwdcache.pw_name = __pw_namecache;
5608
5609 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5610     The identifier's value is usually the UIC, but it doesn't have to be,
5611     so if we can, we let fillpasswd update this. */
5612     __pwdcache.pw_uid =  uic.uic$l_uic;
5613     __pwdcache.pw_gid =  uic.uic$v_group;
5614
5615     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5616     return &__pwdcache;
5617
5618 }  /* end of my_getpwuid() */
5619 /*}}}*/
5620
5621 /*
5622  * Get information for next user.
5623 */
5624 /*{{{struct passwd *my_getpwent()*/
5625 struct passwd *Perl_my_getpwent(pTHX)
5626 {
5627     return (my_getpwuid((unsigned int) -1));
5628 }
5629 /*}}}*/
5630
5631 /*
5632  * Finish searching rights database for users.
5633 */
5634 /*{{{void my_endpwent()*/
5635 void Perl_my_endpwent(pTHX)
5636 {
5637     if (contxt) {
5638       _ckvmssts(sys$finish_rdb(&contxt));
5639       contxt= 0;
5640     }
5641 }
5642 /*}}}*/
5643
5644 #ifdef HOMEGROWN_POSIX_SIGNALS
5645   /* Signal handling routines, pulled into the core from POSIX.xs.
5646    *
5647    * We need these for threads, so they've been rolled into the core,
5648    * rather than left in POSIX.xs.
5649    *
5650    * (DRS, Oct 23, 1997)
5651    */
5652
5653   /* sigset_t is atomic under VMS, so these routines are easy */
5654 /*{{{int my_sigemptyset(sigset_t *) */
5655 int my_sigemptyset(sigset_t *set) {
5656     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5657     *set = 0; return 0;
5658 }
5659 /*}}}*/
5660
5661
5662 /*{{{int my_sigfillset(sigset_t *)*/
5663 int my_sigfillset(sigset_t *set) {
5664     int i;
5665     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5666     for (i = 0; i < NSIG; i++) *set |= (1 << i);
5667     return 0;
5668 }
5669 /*}}}*/
5670
5671
5672 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5673 int my_sigaddset(sigset_t *set, int sig) {
5674     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5675     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5676     *set |= (1 << (sig - 1));
5677     return 0;
5678 }
5679 /*}}}*/
5680
5681
5682 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5683 int my_sigdelset(sigset_t *set, int sig) {
5684     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5685     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5686     *set &= ~(1 << (sig - 1));
5687     return 0;
5688 }
5689 /*}}}*/
5690
5691
5692 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5693 int my_sigismember(sigset_t *set, int sig) {
5694     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5695     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5696     return *set & (1 << (sig - 1));
5697 }
5698 /*}}}*/
5699
5700
5701 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5702 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5703     sigset_t tempmask;
5704
5705     /* If set and oset are both null, then things are badly wrong. Bail out. */
5706     if ((oset == NULL) && (set == NULL)) {
5707       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5708       return -1;
5709     }
5710
5711     /* If set's null, then we're just handling a fetch. */
5712     if (set == NULL) {
5713         tempmask = sigblock(0);
5714     }
5715     else {
5716       switch (how) {
5717       case SIG_SETMASK:
5718         tempmask = sigsetmask(*set);
5719         break;
5720       case SIG_BLOCK:
5721         tempmask = sigblock(*set);
5722         break;
5723       case SIG_UNBLOCK:
5724         tempmask = sigblock(0);
5725         sigsetmask(*oset & ~tempmask);
5726         break;
5727       default:
5728         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5729         return -1;
5730       }
5731     }
5732
5733     /* Did they pass us an oset? If so, stick our holding mask into it */
5734     if (oset)
5735       *oset = tempmask;
5736
5737     return 0;
5738 }
5739 /*}}}*/
5740 #endif  /* HOMEGROWN_POSIX_SIGNALS */
5741
5742
5743 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5744  * my_utime(), and flex_stat(), all of which operate on UTC unless
5745  * VMSISH_TIMES is true.
5746  */
5747 /* method used to handle UTC conversions:
5748  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
5749  */
5750 static int gmtime_emulation_type;
5751 /* number of secs to add to UTC POSIX-style time to get local time */
5752 static long int utc_offset_secs;
5753
5754 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5755  * in vmsish.h.  #undef them here so we can call the CRTL routines
5756  * directly.
5757  */
5758 #undef gmtime
5759 #undef localtime
5760 #undef time
5761
5762
5763 /*
5764  * DEC C previous to 6.0 corrupts the behavior of the /prefix
5765  * qualifier with the extern prefix pragma.  This provisional
5766  * hack circumvents this prefix pragma problem in previous
5767  * precompilers.
5768  */
5769 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5770 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5771 #    pragma __extern_prefix save
5772 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
5773 #    define gmtime decc$__utctz_gmtime
5774 #    define localtime decc$__utctz_localtime
5775 #    define time decc$__utc_time
5776 #    pragma __extern_prefix restore
5777
5778      struct tm *gmtime(), *localtime();
5779
5780 #  endif
5781 #endif
5782
5783
5784 static time_t toutc_dst(time_t loc) {
5785   struct tm *rsltmp;
5786
5787   if ((rsltmp = localtime(&loc)) == NULL) return -1;
5788   loc -= utc_offset_secs;
5789   if (rsltmp->tm_isdst) loc -= 3600;
5790   return loc;
5791 }
5792 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
5793        ((gmtime_emulation_type || my_time(NULL)), \
5794        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5795        ((secs) - utc_offset_secs))))
5796
5797 static time_t toloc_dst(time_t utc) {
5798   struct tm *rsltmp;
5799
5800   utc += utc_offset_secs;
5801   if ((rsltmp = localtime(&utc)) == NULL) return -1;
5802   if (rsltmp->tm_isdst) utc += 3600;
5803   return utc;
5804 }
5805 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
5806        ((gmtime_emulation_type || my_time(NULL)), \
5807        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5808        ((secs) + utc_offset_secs))))
5809
5810 #ifndef RTL_USES_UTC
5811 /*
5812
5813     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
5814         DST starts on 1st sun of april      at 02:00  std time
5815             ends on last sun of october     at 02:00  dst time
5816     see the UCX management command reference, SET CONFIG TIMEZONE
5817     for formatting info.
5818
5819     No, it's not as general as it should be, but then again, NOTHING
5820     will handle UK times in a sensible way.
5821 */
5822
5823
5824 /*
5825     parse the DST start/end info:
5826     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5827 */
5828
5829 static char *
5830 tz_parse_startend(char *s, struct tm *w, int *past)
5831 {
5832     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5833     int ly, dozjd, d, m, n, hour, min, sec, j, k;
5834     time_t g;
5835
5836     if (!s)    return 0;
5837     if (!w) return 0;
5838     if (!past) return 0;
5839
5840     ly = 0;
5841     if (w->tm_year % 4        == 0) ly = 1;
5842     if (w->tm_year % 100      == 0) ly = 0;
5843     if (w->tm_year+1900 % 400 == 0) ly = 1;
5844     if (ly) dinm[1]++;
5845
5846     dozjd = isdigit(*s);
5847     if (*s == 'J' || *s == 'j' || dozjd) {
5848         if (!dozjd && !isdigit(*++s)) return 0;
5849         d = *s++ - '0';
5850         if (isdigit(*s)) {
5851             d = d*10 + *s++ - '0';
5852             if (isdigit(*s)) {
5853                 d = d*10 + *s++ - '0';
5854             }
5855         }
5856         if (d == 0) return 0;
5857         if (d > 366) return 0;
5858         d--;
5859         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
5860         g = d * 86400;
5861         dozjd = 1;
5862     } else if (*s == 'M' || *s == 'm') {
5863         if (!isdigit(*++s)) return 0;
5864         m = *s++ - '0';
5865         if (isdigit(*s)) m = 10*m + *s++ - '0';
5866         if (*s != '.') return 0;
5867         if (!isdigit(*++s)) return 0;
5868         n = *s++ - '0';
5869         if (n < 1 || n > 5) return 0;
5870         if (*s != '.') return 0;
5871         if (!isdigit(*++s)) return 0;
5872         d = *s++ - '0';
5873         if (d > 6) return 0;
5874     }
5875
5876     if (*s == '/') {
5877         if (!isdigit(*++s)) return 0;
5878         hour = *s++ - '0';
5879         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5880         if (*s == ':') {
5881             if (!isdigit(*++s)) return 0;
5882             min = *s++ - '0';
5883             if (isdigit(*s)) min = 10*min + *s++ - '0';
5884             if (*s == ':') {
5885                 if (!isdigit(*++s)) return 0;
5886                 sec = *s++ - '0';
5887                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5888             }
5889         }
5890     } else {
5891         hour = 2;
5892         min = 0;
5893         sec = 0;
5894     }
5895
5896     if (dozjd) {
5897         if (w->tm_yday < d) goto before;
5898         if (w->tm_yday > d) goto after;
5899     } else {
5900         if (w->tm_mon+1 < m) goto before;
5901         if (w->tm_mon+1 > m) goto after;
5902
5903         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
5904         k = d - j; /* mday of first d */
5905         if (k <= 0) k += 7;
5906         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
5907         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5908         if (w->tm_mday < k) goto before;
5909         if (w->tm_mday > k) goto after;
5910     }
5911
5912     if (w->tm_hour < hour) goto before;
5913     if (w->tm_hour > hour) goto after;
5914     if (w->tm_min  < min)  goto before;
5915     if (w->tm_min  > min)  goto after;
5916     if (w->tm_sec  < sec)  goto before;
5917     goto after;
5918
5919 before:
5920     *past = 0;
5921     return s;
5922 after:
5923     *past = 1;
5924     return s;
5925 }
5926
5927
5928
5929
5930 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
5931
5932 static char *
5933 tz_parse_offset(char *s, int *offset)
5934 {
5935     int hour = 0, min = 0, sec = 0;
5936     int neg = 0;
5937     if (!s) return 0;
5938     if (!offset) return 0;
5939
5940     if (*s == '-') {neg++; s++;}
5941     if (*s == '+') s++;
5942     if (!isdigit(*s)) return 0;
5943     hour = *s++ - '0';
5944     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5945     if (hour > 24) return 0;
5946     if (*s == ':') {
5947         if (!isdigit(*++s)) return 0;
5948         min = *s++ - '0';
5949         if (isdigit(*s)) min = min*10 + (*s++ - '0');
5950         if (min > 59) return 0;
5951         if (*s == ':') {
5952             if (!isdigit(*++s)) return 0;
5953             sec = *s++ - '0';
5954             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5955             if (sec > 59) return 0;
5956         }
5957     }
5958
5959     *offset = (hour*60+min)*60 + sec;
5960     if (neg) *offset = -*offset;
5961     return s;
5962 }
5963
5964 /*
5965     input time is w, whatever type of time the CRTL localtime() uses.
5966     sets dst, the zone, and the gmtoff (seconds)
5967
5968     caches the value of TZ and UCX$TZ env variables; note that
5969     my_setenv looks for these and sets a flag if they're changed
5970     for efficiency.
5971
5972     We have to watch out for the "australian" case (dst starts in
5973     october, ends in april)...flagged by "reverse" and checked by
5974     scanning through the months of the previous year.
5975
5976 */
5977
5978 static int
5979 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5980 {
5981     time_t when;
5982     struct tm *w2;
5983     char *s,*s2;
5984     char *dstzone, *tz, *s_start, *s_end;
5985     int std_off, dst_off, isdst;
5986     int y, dststart, dstend;
5987     static char envtz[1025];  /* longer than any logical, symbol, ... */
5988     static char ucxtz[1025];
5989     static char reversed = 0;
5990
5991     if (!w) return 0;
5992
5993     if (tz_updated) {
5994         tz_updated = 0;
5995         reversed = -1;  /* flag need to check  */
5996         envtz[0] = ucxtz[0] = '\0';
5997         tz = my_getenv("TZ",0);
5998         if (tz) strcpy(envtz, tz);
5999         tz = my_getenv("UCX$TZ",0);
6000         if (tz) strcpy(ucxtz, tz);
6001         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
6002     }
6003     tz = envtz;
6004     if (!*tz) tz = ucxtz;
6005
6006     s = tz;
6007     while (isalpha(*s)) s++;
6008     s = tz_parse_offset(s, &std_off);
6009     if (!s) return 0;
6010     if (!*s) {                  /* no DST, hurray we're done! */
6011         isdst = 0;
6012         goto done;
6013     }
6014
6015     dstzone = s;
6016     while (isalpha(*s)) s++;
6017     s2 = tz_parse_offset(s, &dst_off);
6018     if (s2) {
6019         s = s2;
6020     } else {
6021         dst_off = std_off - 3600;
6022     }
6023
6024     if (!*s) {      /* default dst start/end?? */
6025         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
6026             s = strchr(ucxtz,',');
6027         }
6028         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
6029     }
6030     if (*s != ',') return 0;
6031
6032     when = *w;
6033     when = _toutc(when);      /* convert to utc */
6034     when = when - std_off;    /* convert to pseudolocal time*/
6035
6036     w2 = localtime(&when);
6037     y = w2->tm_year;
6038     s_start = s+1;
6039     s = tz_parse_startend(s_start,w2,&dststart);
6040     if (!s) return 0;
6041     if (*s != ',') return 0;
6042
6043     when = *w;
6044     when = _toutc(when);      /* convert to utc */
6045     when = when - dst_off;    /* convert to pseudolocal time*/
6046     w2 = localtime(&when);
6047     if (w2->tm_year != y) {   /* spans a year, just check one time */
6048         when += dst_off - std_off;
6049         w2 = localtime(&when);
6050     }
6051     s_end = s+1;
6052     s = tz_parse_startend(s_end,w2,&dstend);
6053     if (!s) return 0;
6054
6055     if (reversed == -1) {  /* need to check if start later than end */
6056         int j, ds, de;
6057
6058         when = *w;
6059         if (when < 2*365*86400) {
6060             when += 2*365*86400;
6061         } else {
6062             when -= 365*86400;
6063         }
6064         w2 =localtime(&when);
6065         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
6066
6067         for (j = 0; j < 12; j++) {
6068             w2 =localtime(&when);
6069             (void) tz_parse_startend(s_start,w2,&ds);
6070             (void) tz_parse_startend(s_end,w2,&de);
6071             if (ds != de) break;
6072             when += 30*86400;
6073         }
6074         reversed = 0;
6075         if (de && !ds) reversed = 1;
6076     }
6077
6078     isdst = dststart && !dstend;
6079     if (reversed) isdst = dststart  || !dstend;
6080
6081 done:
6082     if (dst)    *dst = isdst;
6083     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6084     if (isdst)  tz = dstzone;
6085     if (zone) {
6086         while(isalpha(*tz))  *zone++ = *tz++;
6087         *zone = '\0';
6088     }
6089     return 1;
6090 }
6091
6092 #endif /* !RTL_USES_UTC */
6093
6094 /* my_time(), my_localtime(), my_gmtime()
6095  * By default traffic in UTC time values, using CRTL gmtime() or
6096  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6097  * Note: We need to use these functions even when the CRTL has working
6098  * UTC support, since they also handle C<use vmsish qw(times);>
6099  *
6100  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
6101  * Modified by Charles Bailey <bailey@newman.upenn.edu>
6102  */
6103
6104 /*{{{time_t my_time(time_t *timep)*/
6105 time_t Perl_my_time(pTHX_ time_t *timep)
6106 {
6107   time_t when;
6108   struct tm *tm_p;
6109
6110   if (gmtime_emulation_type == 0) {
6111     int dstnow;
6112     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
6113                               /* results of calls to gmtime() and localtime() */
6114                               /* for same &base */
6115
6116     gmtime_emulation_type++;
6117     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6118       char off[LNM$C_NAMLENGTH+1];;
6119
6120       gmtime_emulation_type++;
6121       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6122         gmtime_emulation_type++;
6123         utc_offset_secs = 0;
6124         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6125       }
6126       else { utc_offset_secs = atol(off); }
6127     }
6128     else { /* We've got a working gmtime() */
6129       struct tm gmt, local;
6130
6131       gmt = *tm_p;
6132       tm_p = localtime(&base);
6133       local = *tm_p;
6134       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
6135       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6136       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
6137       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
6138     }
6139   }
6140
6141   when = time(NULL);
6142 # ifdef VMSISH_TIME
6143 # ifdef RTL_USES_UTC
6144   if (VMSISH_TIME) when = _toloc(when);
6145 # else
6146   if (!VMSISH_TIME) when = _toutc(when);
6147 # endif
6148 # endif
6149   if (timep != NULL) *timep = when;
6150   return when;
6151
6152 }  /* end of my_time() */
6153 /*}}}*/
6154
6155
6156 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6157 struct tm *
6158 Perl_my_gmtime(pTHX_ const time_t *timep)
6159 {
6160   char *p;
6161   time_t when;
6162   struct tm *rsltmp;
6163
6164   if (timep == NULL) {
6165     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6166     return NULL;
6167   }
6168   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
6169
6170   when = *timep;
6171 # ifdef VMSISH_TIME
6172   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6173 #  endif
6174 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
6175   return gmtime(&when);
6176 # else
6177   /* CRTL localtime() wants local time as input, so does no tz correction */
6178   rsltmp = localtime(&when);
6179   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
6180   return rsltmp;
6181 #endif
6182 }  /* end of my_gmtime() */
6183 /*}}}*/
6184
6185
6186 /*{{{struct tm *my_localtime(const time_t *timep)*/
6187 struct tm *
6188 Perl_my_localtime(pTHX_ const time_t *timep)
6189 {
6190   time_t when, whenutc;
6191   struct tm *rsltmp;
6192   int dst, offset;
6193
6194   if (timep == NULL) {
6195     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6196     return NULL;
6197   }
6198   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
6199   if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6200
6201   when = *timep;
6202 # ifdef RTL_USES_UTC
6203 # ifdef VMSISH_TIME
6204   if (VMSISH_TIME) when = _toutc(when);
6205 # endif
6206   /* CRTL localtime() wants UTC as input, does tz correction itself */
6207   return localtime(&when);
6208
6209 # else /* !RTL_USES_UTC */
6210   whenutc = when;
6211 # ifdef VMSISH_TIME
6212   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
6213   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
6214 # endif
6215   dst = -1;
6216 #ifndef RTL_USES_UTC
6217   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
6218       when = whenutc - offset;                   /* pseudolocal time*/
6219   }
6220 # endif
6221   /* CRTL localtime() wants local time as input, so does no tz correction */
6222   rsltmp = localtime(&when);
6223   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6224   return rsltmp;
6225 # endif
6226
6227 } /*  end of my_localtime() */
6228 /*}}}*/
6229
6230 /* Reset definitions for later calls */
6231 #define gmtime(t)    my_gmtime(t)
6232 #define localtime(t) my_localtime(t)
6233 #define time(t)      my_time(t)
6234
6235
6236 /* my_utime - update modification time of a file
6237  * calling sequence is identical to POSIX utime(), but under
6238  * VMS only the modification time is changed; ODS-2 does not
6239  * maintain access times.  Restrictions differ from the POSIX
6240  * definition in that the time can be changed as long as the
6241  * caller has permission to execute the necessary IO$_MODIFY $QIO;
6242  * no separate checks are made to insure that the caller is the
6243  * owner of the file or has special privs enabled.
6244  * Code here is based on Joe Meadows' FILE utility.
6245  */
6246
6247 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6248  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
6249  * in 100 ns intervals.
6250  */
6251 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6252
6253 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6254 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6255 {
6256   register int i;
6257   long int bintime[2], len = 2, lowbit, unixtime,
6258            secscale = 10000000; /* seconds --> 100 ns intervals */
6259   unsigned long int chan, iosb[2], retsts;
6260   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6261   struct FAB myfab = cc$rms_fab;
6262   struct NAM mynam = cc$rms_nam;
6263 #if defined (__DECC) && defined (__VAX)
6264   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6265    * at least through VMS V6.1, which causes a type-conversion warning.
6266    */
6267 #  pragma message save
6268 #  pragma message disable cvtdiftypes
6269 #endif
6270   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6271   struct fibdef myfib;
6272 #if defined (__DECC) && defined (__VAX)
6273   /* This should be right after the declaration of myatr, but due
6274    * to a bug in VAX DEC C, this takes effect a statement early.
6275    */
6276 #  pragma message restore
6277 #endif
6278   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6279                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6280                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6281
6282   if (file == NULL || *file == '\0') {
6283     set_errno(ENOENT);
6284     set_vaxc_errno(LIB$_INVARG);
6285     return -1;
6286   }
6287   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6288
6289   if (utimes != NULL) {
6290     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
6291      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6292      * Since time_t is unsigned long int, and lib$emul takes a signed long int
6293      * as input, we force the sign bit to be clear by shifting unixtime right
6294      * one bit, then multiplying by an extra factor of 2 in lib$emul().
6295      */
6296     lowbit = (utimes->modtime & 1) ? secscale : 0;
6297     unixtime = (long int) utimes->modtime;
6298 #   ifdef VMSISH_TIME
6299     /* If input was UTC; convert to local for sys svc */
6300     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6301 #   endif
6302     unixtime >>= 1;  secscale <<= 1;
6303     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6304     if (!(retsts & 1)) {
6305       set_errno(EVMSERR);
6306       set_vaxc_errno(retsts);
6307       return -1;
6308     }
6309     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6310     if (!(retsts & 1)) {
6311       set_errno(EVMSERR);
6312       set_vaxc_errno(retsts);
6313       return -1;
6314     }
6315   }
6316   else {
6317     /* Just get the current time in VMS format directly */
6318     retsts = sys$gettim(bintime);
6319     if (!(retsts & 1)) {
6320       set_errno(EVMSERR);
6321       set_vaxc_errno(retsts);
6322       return -1;
6323     }
6324   }
6325
6326   myfab.fab$l_fna = vmsspec;
6327   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6328   myfab.fab$l_nam = &mynam;
6329   mynam.nam$l_esa = esa;
6330   mynam.nam$b_ess = (unsigned char) sizeof esa;
6331   mynam.nam$l_rsa = rsa;
6332   mynam.nam$b_rss = (unsigned char) sizeof rsa;
6333
6334   /* Look for the file to be affected, letting RMS parse the file
6335    * specification for us as well.  I have set errno using only
6336    * values documented in the utime() man page for VMS POSIX.
6337    */
6338   retsts = sys$parse(&myfab,0,0);
6339   if (!(retsts & 1)) {
6340     set_vaxc_errno(retsts);
6341     if      (retsts == RMS$_PRV) set_errno(EACCES);
6342     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6343     else                         set_errno(EVMSERR);
6344     return -1;
6345   }
6346   retsts = sys$search(&myfab,0,0);
6347   if (!(retsts & 1)) {
6348     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6349     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6350     set_vaxc_errno(retsts);
6351     if      (retsts == RMS$_PRV) set_errno(EACCES);
6352     else if (retsts == RMS$_FNF) set_errno(ENOENT);
6353     else                         set_errno(EVMSERR);
6354     return -1;
6355   }
6356
6357   devdsc.dsc$w_length = mynam.nam$b_dev;
6358   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6359
6360   retsts = sys$assign(&devdsc,&chan,0,0);
6361   if (!(retsts & 1)) {
6362     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6363     myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6364     set_vaxc_errno(retsts);
6365     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
6366     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
6367     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
6368     else                               set_errno(EVMSERR);
6369     return -1;
6370   }
6371
6372   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6373   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6374
6375   memset((void *) &myfib, 0, sizeof myfib);
6376 #if defined(__DECC) || defined(__DECCXX)
6377   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6378   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6379   /* This prevents the revision time of the file being reset to the current
6380    * time as a result of our IO$_MODIFY $QIO. */
6381   myfib.fib$l_acctl = FIB$M_NORECORD;
6382 #else
6383   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6384   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6385   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6386 #endif
6387   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6388   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
6389   myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
6390   _ckvmssts(sys$dassgn(chan));
6391   if (retsts & 1) retsts = iosb[0];
6392   if (!(retsts & 1)) {
6393     set_vaxc_errno(retsts);
6394     if (retsts == SS$_NOPRIV) set_errno(EACCES);
6395     else                      set_errno(EVMSERR);
6396     return -1;
6397   }
6398
6399   return 0;
6400 }  /* end of my_utime() */
6401 /*}}}*/
6402
6403 /*
6404  * flex_stat, flex_fstat
6405  * basic stat, but gets it right when asked to stat
6406  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6407  */
6408
6409 /* encode_dev packs a VMS device name string into an integer to allow
6410  * simple comparisons. This can be used, for example, to check whether two
6411  * files are located on the same device, by comparing their encoded device
6412  * names. Even a string comparison would not do, because stat() reuses the
6413  * device name buffer for each call; so without encode_dev, it would be
6414  * necessary to save the buffer and use strcmp (this would mean a number of
6415  * changes to the standard Perl code, to say nothing of what a Perl script
6416  * would have to do.
6417  *
6418  * The device lock id, if it exists, should be unique (unless perhaps compared
6419  * with lock ids transferred from other nodes). We have a lock id if the disk is
6420  * mounted cluster-wide, which is when we tend to get long (host-qualified)
6421  * device names. Thus we use the lock id in preference, and only if that isn't
6422  * available, do we try to pack the device name into an integer (flagged by
6423  * the sign bit (LOCKID_MASK) being set).
6424  *
6425  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6426  * name and its encoded form, but it seems very unlikely that we will find
6427  * two files on different disks that share the same encoded device names,
6428  * and even more remote that they will share the same file id (if the test
6429  * is to check for the same file).
6430  *
6431  * A better method might be to use sys$device_scan on the first call, and to
6432  * search for the device, returning an index into the cached array.
6433  * The number returned would be more intelligable.
6434  * This is probably not worth it, and anyway would take quite a bit longer
6435  * on the first call.
6436  */
6437 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
6438 static mydev_t encode_dev (pTHX_ const char *dev)
6439 {
6440   int i;
6441   unsigned long int f;
6442   mydev_t enc;
6443   char c;
6444   const char *q;
6445
6446   if (!dev || !dev[0]) return 0;
6447
6448 #if LOCKID_MASK
6449   {
6450     struct dsc$descriptor_s dev_desc;
6451     unsigned long int status, lockid, item = DVI$_LOCKID;
6452
6453     /* For cluster-mounted disks, the disk lock identifier is unique, so we
6454        can try that first. */
6455     dev_desc.dsc$w_length =  strlen (dev);
6456     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
6457     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
6458     dev_desc.dsc$a_pointer = (char *) dev;
6459     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6460     if (lockid) return (lockid & ~LOCKID_MASK);
6461   }
6462 #endif
6463
6464   /* Otherwise we try to encode the device name */
6465   enc = 0;
6466   f = 1;
6467   i = 0;
6468   for (q = dev + strlen(dev); q--; q >= dev) {
6469     if (isdigit (*q))
6470       c= (*q) - '0';
6471     else if (isalpha (toupper (*q)))
6472       c= toupper (*q) - 'A' + (char)10;
6473     else
6474       continue; /* Skip '$'s */
6475     i++;
6476     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
6477     if (i>1) f *= 36;
6478     enc += f * (unsigned long int) c;
6479   }
6480   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
6481
6482 }  /* end of encode_dev() */
6483
6484 static char namecache[NAM$C_MAXRSS+1];
6485
6486 static int
6487 is_null_device(name)
6488     const char *name;
6489 {
6490     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6491        The underscore prefix, controller letter, and unit number are
6492        independently optional; for our purposes, the colon punctuation
6493        is not.  The colon can be trailed by optional directory and/or
6494        filename, but two consecutive colons indicates a nodename rather
6495        than a device.  [pr]  */
6496   if (*name == '_') ++name;
6497   if (tolower(*name++) != 'n') return 0;
6498   if (tolower(*name++) != 'l') return 0;
6499   if (tolower(*name) == 'a') ++name;
6500   if (*name == '0') ++name;
6501   return (*name++ == ':') && (*name != ':');
6502 }
6503
6504 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
6505 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6506  * subset of the applicable information.
6507  */
6508 bool
6509 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6510 {
6511   char fname_phdev[NAM$C_MAXRSS+1];
6512   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6513   else {
6514     char fname[NAM$C_MAXRSS+1];
6515     unsigned long int retsts;
6516     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6517                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6518
6519     /* If the struct mystat is stale, we're OOL; stat() overwrites the
6520        device name on successive calls */
6521     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6522     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6523     namdsc.dsc$a_pointer = fname;
6524     namdsc.dsc$w_length = sizeof fname - 1;
6525
6526     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6527                              &namdsc,&namdsc.dsc$w_length,0,0);
6528     if (retsts & 1) {
6529       fname[namdsc.dsc$w_length] = '\0';
6530 /*
6531  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6532  * but if someone has redefined that logical, Perl gets very lost.  Since
6533  * we have the physical device name from the stat buffer, just paste it on.
6534  */
6535       strcpy( fname_phdev, statbufp->st_devnam );
6536       strcat( fname_phdev, strrchr(fname, ':') );
6537
6538       return cando_by_name(bit,effective,fname_phdev);
6539     }
6540     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6541       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6542       return FALSE;
6543     }
6544     _ckvmssts(retsts);
6545     return FALSE;  /* Should never get to here */
6546   }
6547 }  /* end of cando() */
6548 /*}}}*/
6549
6550
6551 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6552 I32
6553 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6554 {
6555   static char usrname[L_cuserid];
6556   static struct dsc$descriptor_s usrdsc =
6557          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6558   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6559   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6560   unsigned short int retlen, trnlnm_iter_count;
6561   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6562   union prvdef curprv;
6563   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6564          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6565   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6566          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6567          {0,0,0,0}};
6568   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6569          {0,0,0,0}};
6570   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6571
6572   if (!fname || !*fname) return FALSE;
6573   /* Make sure we expand logical names, since sys$check_access doesn't */
6574   if (!strpbrk(fname,"/]>:")) {
6575     strcpy(fileified,fname);
6576     trnlnm_iter_count = 0;
6577     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
6578         trnlnm_iter_count++;
6579         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6580     }
6581     fname = fileified;
6582   }
6583   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6584   retlen = namdsc.dsc$w_length = strlen(vmsname);
6585   namdsc.dsc$a_pointer = vmsname;
6586   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6587       vmsname[retlen-1] == ':') {
6588     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6589     namdsc.dsc$w_length = strlen(fileified);
6590     namdsc.dsc$a_pointer = fileified;
6591   }
6592
6593   switch (bit) {
6594     case S_IXUSR: case S_IXGRP: case S_IXOTH:
6595       access = ARM$M_EXECUTE; break;
6596     case S_IRUSR: case S_IRGRP: case S_IROTH:
6597       access = ARM$M_READ; break;
6598     case S_IWUSR: case S_IWGRP: case S_IWOTH:
6599       access = ARM$M_WRITE; break;
6600     case S_IDUSR: case S_IDGRP: case S_IDOTH:
6601       access = ARM$M_DELETE; break;
6602     default:
6603       return FALSE;
6604   }
6605
6606   /* Before we call $check_access, create a user profile with the current
6607    * process privs since otherwise it just uses the default privs from the
6608    * UAF and might give false positives or negatives.  This only works on
6609    * VMS versions v6.0 and later since that's when sys$create_user_profile
6610    * became available.
6611    */
6612
6613   /* get current process privs and username */
6614   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6615   _ckvmssts(iosb[0]);
6616
6617 #if defined(__VMS_VER) && __VMS_VER >= 60000000
6618
6619   /* find out the space required for the profile */
6620   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6621                                     &usrprodsc.dsc$w_length,0));
6622
6623   /* allocate space for the profile and get it filled in */
6624   New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6625   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6626                                     &usrprodsc.dsc$w_length,0));
6627
6628   /* use the profile to check access to the file; free profile & analyze results */
6629   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6630   Safefree(usrprodsc.dsc$a_pointer);
6631   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6632
6633 #else
6634
6635   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6636
6637 #endif
6638
6639   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
6640       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6641       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6642     set_vaxc_errno(retsts);
6643     if (retsts == SS$_NOPRIV) set_errno(EACCES);
6644     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6645     else set_errno(ENOENT);
6646     return FALSE;
6647   }
6648   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6649     return TRUE;
6650   }
6651   _ckvmssts(retsts);
6652
6653   return FALSE;  /* Should never get here */
6654
6655 }  /* end of cando_by_name() */
6656 /*}}}*/
6657
6658
6659 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6660 int
6661 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6662 {
6663   if (!fstat(fd,(stat_t *) statbufp)) {
6664     if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6665     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6666 #   ifdef RTL_USES_UTC
6667 #   ifdef VMSISH_TIME
6668     if (VMSISH_TIME) {
6669       statbufp->st_mtime = _toloc(statbufp->st_mtime);
6670       statbufp->st_atime = _toloc(statbufp->st_atime);
6671       statbufp->st_ctime = _toloc(statbufp->st_ctime);
6672     }
6673 #   endif
6674 #   else
6675 #   ifdef VMSISH_TIME
6676     if (!VMSISH_TIME) { /* Return UTC instead of local time */
6677 #   else
6678     if (1) {
6679 #   endif
6680       statbufp->st_mtime = _toutc(statbufp->st_mtime);
6681       statbufp->st_atime = _toutc(statbufp->st_atime);
6682       statbufp->st_ctime = _toutc(statbufp->st_ctime);
6683     }
6684 #endif
6685     return 0;
6686   }
6687   return -1;
6688
6689 }  /* end of flex_fstat() */
6690 /*}}}*/
6691
6692 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6693 int
6694 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6695 {
6696     char fileified[NAM$C_MAXRSS+1];
6697     char temp_fspec[NAM$C_MAXRSS+300];
6698     int retval = -1;
6699     int saved_errno, saved_vaxc_errno;
6700
6701     if (!fspec) return retval;
6702     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6703     strcpy(temp_fspec, fspec);
6704     if (statbufp == (Stat_t *) &PL_statcache)
6705       do_tovmsspec(temp_fspec,namecache,0);
6706     if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6707       memset(statbufp,0,sizeof *statbufp);
6708       statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6709       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6710       statbufp->st_uid = 0x00010001;
6711       statbufp->st_gid = 0x0001;
6712       time((time_t *)&statbufp->st_mtime);
6713       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6714       return 0;
6715     }
6716
6717     /* Try for a directory name first.  If fspec contains a filename without
6718      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6719      * and sea:[wine.dark]water. exist, we prefer the directory here.
6720      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6721      * not sea:[wine.dark]., if the latter exists.  If the intended target is
6722      * the file with null type, specify this by calling flex_stat() with
6723      * a '.' at the end of fspec.
6724      */
6725     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6726       retval = stat(fileified,(stat_t *) statbufp);
6727       if (!retval && statbufp == (Stat_t *) &PL_statcache)
6728         strcpy(namecache,fileified);
6729     }
6730     if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6731     if (!retval) {
6732       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6733 #     ifdef RTL_USES_UTC
6734 #     ifdef VMSISH_TIME
6735       if (VMSISH_TIME) {
6736         statbufp->st_mtime = _toloc(statbufp->st_mtime);
6737         statbufp->st_atime = _toloc(statbufp->st_atime);
6738         statbufp->st_ctime = _toloc(statbufp->st_ctime);
6739       }
6740 #     endif
6741 #     else
6742 #     ifdef VMSISH_TIME
6743       if (!VMSISH_TIME) { /* Return UTC instead of local time */
6744 #     else
6745       if (1) {
6746 #     endif
6747         statbufp->st_mtime = _toutc(statbufp->st_mtime);
6748         statbufp->st_atime = _toutc(statbufp->st_atime);
6749         statbufp->st_ctime = _toutc(statbufp->st_ctime);
6750       }
6751 #     endif
6752     }
6753     /* If we were successful, leave errno where we found it */
6754     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6755     return retval;
6756
6757 }  /* end of flex_stat() */
6758 /*}}}*/
6759
6760
6761 /*{{{char *my_getlogin()*/
6762 /* VMS cuserid == Unix getlogin, except calling sequence */
6763 char *
6764 my_getlogin()
6765 {
6766     static char user[L_cuserid];
6767     return cuserid(user);
6768 }
6769 /*}}}*/
6770
6771
6772 /*  rmscopy - copy a file using VMS RMS routines
6773  *
6774  *  Copies contents and attributes of spec_in to spec_out, except owner
6775  *  and protection information.  Name and type of spec_in are used as
6776  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
6777  *  should try to propagate timestamps from the input file to the output file.
6778  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
6779  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
6780  *  propagated to the output file at creation iff the output file specification
6781  *  did not contain an explicit name or type, and the revision date is always
6782  *  updated at the end of the copy operation.  If it is greater than 0, then
6783  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6784  *  other than the revision date should be propagated, and bit 1 indicates
6785  *  that the revision date should be propagated.
6786  *
6787  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6788  *
6789  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6790  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
6791  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
6792  * as part of the Perl standard distribution under the terms of the
6793  * GNU General Public License or the Perl Artistic License.  Copies
6794  * of each may be found in the Perl standard distribution.
6795  */
6796 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6797 int
6798 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6799 {
6800     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6801          rsa[NAM$C_MAXRSS], ubf[32256];
6802     unsigned long int i, sts, sts2;
6803     struct FAB fab_in, fab_out;
6804     struct RAB rab_in, rab_out;
6805     struct NAM nam;
6806     struct XABDAT xabdat;
6807     struct XABFHC xabfhc;
6808     struct XABRDT xabrdt;
6809     struct XABSUM xabsum;
6810
6811     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
6812         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6813       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6814       return 0;
6815     }
6816
6817     fab_in = cc$rms_fab;
6818     fab_in.fab$l_fna = vmsin;
6819     fab_in.fab$b_fns = strlen(vmsin);
6820     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6821     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6822     fab_in.fab$l_fop = FAB$M_SQO;
6823     fab_in.fab$l_nam =  &nam;
6824     fab_in.fab$l_xab = (void *) &xabdat;
6825
6826     nam = cc$rms_nam;
6827     nam.nam$l_rsa = rsa;
6828     nam.nam$b_rss = sizeof(rsa);
6829     nam.nam$l_esa = esa;
6830     nam.nam$b_ess = sizeof (esa);
6831     nam.nam$b_esl = nam.nam$b_rsl = 0;
6832
6833     xabdat = cc$rms_xabdat;        /* To get creation date */
6834     xabdat.xab$l_nxt = (void *) &xabfhc;
6835
6836     xabfhc = cc$rms_xabfhc;        /* To get record length */
6837     xabfhc.xab$l_nxt = (void *) &xabsum;
6838
6839     xabsum = cc$rms_xabsum;        /* To get key and area information */
6840
6841     if (!((sts = sys$open(&fab_in)) & 1)) {
6842       set_vaxc_errno(sts);
6843       switch (sts) {
6844         case RMS$_FNF: case RMS$_DNF:
6845           set_errno(ENOENT); break;
6846         case RMS$_DIR:
6847           set_errno(ENOTDIR); break;
6848         case RMS$_DEV:
6849           set_errno(ENODEV); break;
6850         case RMS$_SYN:
6851           set_errno(EINVAL); break;
6852         case RMS$_PRV:
6853           set_errno(EACCES); break;
6854         default:
6855           set_errno(EVMSERR);
6856       }
6857       return 0;
6858     }
6859
6860     fab_out = fab_in;
6861     fab_out.fab$w_ifi = 0;
6862     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6863     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6864     fab_out.fab$l_fop = FAB$M_SQO;
6865     fab_out.fab$l_fna = vmsout;
6866     fab_out.fab$b_fns = strlen(vmsout);
6867     fab_out.fab$l_dna = nam.nam$l_name;
6868     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6869
6870     if (preserve_dates == 0) {  /* Act like DCL COPY */
6871       nam.nam$b_nop = NAM$M_SYNCHK;
6872       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
6873       if (!((sts = sys$parse(&fab_out)) & 1)) {
6874         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6875         set_vaxc_errno(sts);
6876         return 0;
6877       }
6878       fab_out.fab$l_xab = (void *) &xabdat;
6879       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6880     }
6881     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
6882     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
6883       preserve_dates =0;      /* bitmask from this point forward   */
6884
6885     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6886     if (!((sts = sys$create(&fab_out)) & 1)) {
6887       set_vaxc_errno(sts);
6888       switch (sts) {
6889         case RMS$_DNF:
6890           set_errno(ENOENT); break;
6891         case RMS$_DIR:
6892           set_errno(ENOTDIR); break;
6893         case RMS$_DEV:
6894           set_errno(ENODEV); break;
6895         case RMS$_SYN:
6896           set_errno(EINVAL); break;
6897         case RMS$_PRV:
6898           set_errno(EACCES); break;
6899         default:
6900           set_errno(EVMSERR);
6901       }
6902       return 0;
6903     }
6904     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
6905     if (preserve_dates & 2) {
6906       /* sys$close() will process xabrdt, not xabdat */
6907       xabrdt = cc$rms_xabrdt;
6908 #ifndef __GNUC__
6909       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6910 #else
6911       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6912        * is unsigned long[2], while DECC & VAXC use a struct */
6913       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6914 #endif
6915       fab_out.fab$l_xab = (void *) &xabrdt;
6916     }
6917
6918     rab_in = cc$rms_rab;
6919     rab_in.rab$l_fab = &fab_in;
6920     rab_in.rab$l_rop = RAB$M_BIO;
6921     rab_in.rab$l_ubf = ubf;
6922     rab_in.rab$w_usz = sizeof ubf;
6923     if (!((sts = sys$connect(&rab_in)) & 1)) {
6924       sys$close(&fab_in); sys$close(&fab_out);
6925       set_errno(EVMSERR); set_vaxc_errno(sts);
6926       return 0;
6927     }
6928
6929     rab_out = cc$rms_rab;
6930     rab_out.rab$l_fab = &fab_out;
6931     rab_out.rab$l_rbf = ubf;
6932     if (!((sts = sys$connect(&rab_out)) & 1)) {
6933       sys$close(&fab_in); sys$close(&fab_out);
6934       set_errno(EVMSERR); set_vaxc_errno(sts);
6935       return 0;
6936     }
6937
6938     while ((sts = sys$read(&rab_in))) {  /* always true  */
6939       if (sts == RMS$_EOF) break;
6940       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6941       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6942         sys$close(&fab_in); sys$close(&fab_out);
6943         set_errno(EVMSERR); set_vaxc_errno(sts);
6944         return 0;
6945       }
6946     }
6947
6948     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
6949     sys$close(&fab_in);  sys$close(&fab_out);
6950     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6951     if (!(sts & 1)) {
6952       set_errno(EVMSERR); set_vaxc_errno(sts);
6953       return 0;
6954     }
6955
6956     return 1;
6957
6958 }  /* end of rmscopy() */
6959 /*}}}*/
6960
6961
6962 /***  The following glue provides 'hooks' to make some of the routines
6963  * from this file available from Perl.  These routines are sufficiently
6964  * basic, and are required sufficiently early in the build process,
6965  * that's it's nice to have them available to miniperl as well as the
6966  * full Perl, so they're set up here instead of in an extension.  The
6967  * Perl code which handles importation of these names into a given
6968  * package lives in [.VMS]Filespec.pm in @INC.
6969  */
6970
6971 void
6972 rmsexpand_fromperl(pTHX_ CV *cv)
6973 {
6974   dXSARGS;
6975   char *fspec, *defspec = NULL, *rslt;
6976   STRLEN n_a;
6977
6978   if (!items || items > 2)
6979     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6980   fspec = SvPV(ST(0),n_a);
6981   if (!fspec || !*fspec) XSRETURN_UNDEF;
6982   if (items == 2) defspec = SvPV(ST(1),n_a);
6983
6984   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6985   ST(0) = sv_newmortal();
6986   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6987   XSRETURN(1);
6988 }
6989
6990 void
6991 vmsify_fromperl(pTHX_ CV *cv)
6992 {
6993   dXSARGS;
6994   char *vmsified;
6995   STRLEN n_a;
6996
6997   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6998   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6999   ST(0) = sv_newmortal();
7000   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7001   XSRETURN(1);
7002 }
7003
7004 void
7005 unixify_fromperl(pTHX_ CV *cv)
7006 {
7007   dXSARGS;
7008   char *unixified;
7009   STRLEN n_a;
7010
7011   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7012   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7013   ST(0) = sv_newmortal();
7014   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7015   XSRETURN(1);
7016 }
7017
7018 void
7019 fileify_fromperl(pTHX_ CV *cv)
7020 {
7021   dXSARGS;
7022   char *fileified;
7023   STRLEN n_a;
7024
7025   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7026   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7027   ST(0) = sv_newmortal();
7028   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7029   XSRETURN(1);
7030 }
7031
7032 void
7033 pathify_fromperl(pTHX_ CV *cv)
7034 {
7035   dXSARGS;
7036   char *pathified;
7037   STRLEN n_a;
7038
7039   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7040   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7041   ST(0) = sv_newmortal();
7042   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7043   XSRETURN(1);
7044 }
7045
7046 void
7047 vmspath_fromperl(pTHX_ CV *cv)
7048 {
7049   dXSARGS;
7050   char *vmspath;
7051   STRLEN n_a;
7052
7053   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7054   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7055   ST(0) = sv_newmortal();
7056   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7057   XSRETURN(1);
7058 }
7059
7060 void
7061 unixpath_fromperl(pTHX_ CV *cv)
7062 {
7063   dXSARGS;
7064   char *unixpath;
7065   STRLEN n_a;
7066
7067   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7068   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7069   ST(0) = sv_newmortal();
7070   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7071   XSRETURN(1);
7072 }
7073
7074 void
7075 candelete_fromperl(pTHX_ CV *cv)
7076 {
7077   dXSARGS;
7078   char fspec[NAM$C_MAXRSS+1], *fsp;
7079   SV *mysv;
7080   IO *io;
7081   STRLEN n_a;
7082
7083   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7084
7085   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7086   if (SvTYPE(mysv) == SVt_PVGV) {
7087     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7088       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7089       ST(0) = &PL_sv_no;
7090       XSRETURN(1);
7091     }
7092     fsp = fspec;
7093   }
7094   else {
7095     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7096       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7097       ST(0) = &PL_sv_no;
7098       XSRETURN(1);
7099     }
7100   }
7101
7102   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7103   XSRETURN(1);
7104 }
7105
7106 void
7107 rmscopy_fromperl(pTHX_ CV *cv)
7108 {
7109   dXSARGS;
7110   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7111   int date_flag;
7112   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7113                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7114   unsigned long int sts;
7115   SV *mysv;
7116   IO *io;
7117   STRLEN n_a;
7118
7119   if (items < 2 || items > 3)
7120     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7121
7122   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7123   if (SvTYPE(mysv) == SVt_PVGV) {
7124     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7125       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7126       ST(0) = &PL_sv_no;
7127       XSRETURN(1);
7128     }
7129     inp = inspec;
7130   }
7131   else {
7132     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7133       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7134       ST(0) = &PL_sv_no;
7135       XSRETURN(1);
7136     }
7137   }
7138   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7139   if (SvTYPE(mysv) == SVt_PVGV) {
7140     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7141       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7142       ST(0) = &PL_sv_no;
7143       XSRETURN(1);
7144     }
7145     outp = outspec;
7146   }
7147   else {
7148     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7149       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7150       ST(0) = &PL_sv_no;
7151       XSRETURN(1);
7152     }
7153   }
7154   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7155
7156   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7157   XSRETURN(1);
7158 }
7159
7160
7161 void
7162 mod2fname(pTHX_ CV *cv)
7163 {
7164   dXSARGS;
7165   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7166        workbuff[NAM$C_MAXRSS*1 + 1];
7167   int total_namelen = 3, counter, num_entries;
7168   /* ODS-5 ups this, but we want to be consistent, so... */
7169   int max_name_len = 39;
7170   AV *in_array = (AV *)SvRV(ST(0));
7171
7172   num_entries = av_len(in_array);
7173
7174   /* All the names start with PL_. */
7175   strcpy(ultimate_name, "PL_");
7176
7177   /* Clean up our working buffer */
7178   Zero(work_name, sizeof(work_name), char);
7179
7180   /* Run through the entries and build up a working name */
7181   for(counter = 0; counter <= num_entries; counter++) {
7182     /* If it's not the first name then tack on a __ */
7183     if (counter) {
7184       strcat(work_name, "__");
7185     }
7186     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7187                            PL_na));
7188   }
7189
7190   /* Check to see if we actually have to bother...*/
7191   if (strlen(work_name) + 3 <= max_name_len) {
7192     strcat(ultimate_name, work_name);
7193   } else {
7194     /* It's too darned big, so we need to go strip. We use the same */
7195     /* algorithm as xsubpp does. First, strip out doubled __ */
7196     char *source, *dest, last;
7197     dest = workbuff;
7198     last = 0;
7199     for (source = work_name; *source; source++) {
7200       if (last == *source && last == '_') {
7201         continue;
7202       }
7203       *dest++ = *source;
7204       last = *source;
7205     }
7206     /* Go put it back */
7207     strcpy(work_name, workbuff);
7208     /* Is it still too big? */
7209     if (strlen(work_name) + 3 > max_name_len) {
7210       /* Strip duplicate letters */
7211       last = 0;
7212       dest = workbuff;
7213       for (source = work_name; *source; source++) {
7214         if (last == toupper(*source)) {
7215         continue;
7216         }
7217         *dest++ = *source;
7218         last = toupper(*source);
7219       }
7220       strcpy(work_name, workbuff);
7221     }
7222
7223     /* Is it *still* too big? */
7224     if (strlen(work_name) + 3 > max_name_len) {
7225       /* Too bad, we truncate */
7226       work_name[max_name_len - 2] = 0;
7227     }
7228     strcat(ultimate_name, work_name);
7229   }
7230
7231   /* Okay, return it */
7232   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7233   XSRETURN(1);
7234 }
7235
7236 void
7237 hushexit_fromperl(pTHX_ CV *cv)
7238 {
7239     dXSARGS;
7240
7241     if (items > 0) {
7242         VMSISH_HUSHED = SvTRUE(ST(0));
7243     }
7244     ST(0) = boolSV(VMSISH_HUSHED);
7245     XSRETURN(1);
7246 }
7247
7248 void
7249 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7250                           struct interp_intern *dst)
7251 {
7252     memcpy(dst,src,sizeof(struct interp_intern));
7253 }
7254
7255 void
7256 Perl_sys_intern_clear(pTHX)
7257 {
7258 }
7259
7260 void
7261 Perl_sys_intern_init(pTHX)
7262 {
7263     unsigned int ix = RAND_MAX;
7264     double x;
7265
7266     VMSISH_HUSHED = 0;
7267
7268     x = (float)ix;
7269     MY_INV_RAND_MAX = 1./x;
7270 }
7271
7272 void
7273 init_os_extras()
7274 {
7275   dTHX;
7276   char* file = __FILE__;
7277   char temp_buff[512];
7278   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7279     no_translate_barewords = TRUE;
7280   } else {
7281     no_translate_barewords = FALSE;
7282   }
7283
7284   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7285   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7286   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7287   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7288   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7289   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7290   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7291   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7292   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7293   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7294   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7295
7296   store_pipelocs(aTHX);         /* will redo any earlier attempts */
7297
7298   return;
7299 }
7300
7301 /*  End of vms.c */