vms/vms.c

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