vms/vms.c

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