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