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