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