vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  *
   5  * Last revised: 24-Jun-1996 by Charles Bailey  bailey@genetics.upenn.edu
   6  * Version: 5.3.0
   7  */
   8
   9 #include <acedef.h>
  10 #include <acldef.h>
  11 #include <armdef.h>
  12 #include <atrdef.h>
  13 #include <chpdef.h>
  14 #include <climsgdef.h>
  15 #include <descrip.h>
  16 #include <dvidef.h>
  17 #include <fibdef.h>
  18 #include <float.h>
  19 #include <fscndef.h>
  20 #include <iodef.h>
  21 #include <jpidef.h>
  22 #include <libdef.h>
  23 #include <lib$routines.h>
  24 #include <lnmdef.h>
  25 #include <prvdef.h>
  26 #include <psldef.h>
  27 #include <rms.h>
  28 #include <shrdef.h>
  29 #include <ssdef.h>
  30 #include <starlet.h>
  31 #include <stsdef.h>
  32 #include <syidef.h>
  33 #include <uaidef.h>
  34 #include <uicdef.h>
  35
  36 #include "EXTERN.h"
  37 #include "perl.h"
  38 #include "XSUB.h"
  39
  40 /* gcc's header files don't #define direct access macros
  41  * corresponding to VAXC's variant structs */
  42 #ifdef __GNUC__
  43 #  define uic$v_format uic$r_uic_form.uic$v_format
  44 #  define uic$v_group uic$r_uic_form.uic$v_group
  45 #  define uic$v_member uic$r_uic_form.uic$v_member
  46 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
  47 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
  48 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
  49 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
  50 #endif
  51
  52
  53 struct itmlst_3 {
  54   unsigned short int buflen;
  55   unsigned short int itmcode;
  56   void *bufadr;
  57   unsigned short int *retlen;
  58 };
  59
  60 static char *__mystrtolower(char *str)
  61 {
  62   if (str) for (; *str; ++str) *str= tolower(*str);
  63   return str;
  64 }
  65
  66 int
  67 my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
  68 {
  69     static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
  70     unsigned short int eqvlen;
  71     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
  72     $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
  73     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
  74     struct itmlst_3 lnmlst[3] = {{sizeof idx,      LNM$_INDEX,  &idx, 0},
  75                                  {LNM$C_NAMLENGTH, LNM$_STRING, 0,    &eqvlen},
  76                                  {0, 0, 0, 0}};
  77
  78     if (!eqv) eqv = __my_trnlnm_eqv;
  79     lnmlst[1].bufadr = (void *)eqv;
  80     lnmdsc.dsc$a_pointer = lnm;
  81     lnmdsc.dsc$w_length = strlen(lnm);
  82     retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
  83     if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) {
  84       set_vaxc_errno(retsts); set_errno(EINVAL); return 0;
  85     }
  86     else if (retsts & 1) {
  87       eqv[eqvlen] = '\0';
  88       return 1;
  89     }
  90     _ckvmssts(retsts);  /* Must be an error */
  91     return 0;      /* Not reached, assuming _ckvmssts() bails out */
  92
  93 }  /* end of my_trnlnm */
  94
  95 /* my_getenv
  96  * Translate a logical name.  Substitute for CRTL getenv() to avoid
  97  * memory leak, and to keep my_getenv() and my_setenv() in the same
  98  * domain (mostly - my_getenv() need not return a translation from
  99  * the process logical name table)
 100  *
 101  * Note: Uses static buffer -- not thread-safe!
 102  */
 103 /*{{{ char *my_getenv(char *lnm)*/
 104 char *
 105 my_getenv(char *lnm)
 106 {
 107     static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
 108     char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
 109     unsigned long int idx = 0;
 110
 111     for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
 112     *cp2 = '\0';
 113     if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
 114       getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
 115       return __my_getenv_eqv;
 116     }
 117     else {
 118       if ((cp2 = strchr(uplnm,';')) != NULL) {
 119         *cp2 = '\0';
 120         idx = strtoul(cp2+1,NULL,0);
 121       }
 122       if (my_trnlnm(uplnm,__my_getenv_eqv,idx)) {
 123         return __my_getenv_eqv;
 124       }
 125       else {
 126         unsigned long int retsts;
 127         struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 128                                 valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
 129                                           DSC$K_CLASS_S, __my_getenv_eqv};
 130         symdsc.dsc$w_length = cp1 - lnm;
 131         symdsc.dsc$a_pointer = uplnm;
 132         retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
 133         if (retsts == LIB$_INVSYMNAM) return Nullch;
 134         if (retsts != LIB$_NOSUCHSYM) {
 135           /* We want to return only logical names or CRTL Unix emulations */
 136           if (retsts & 1) return Nullch;
 137           _ckvmssts(retsts);
 138         }
 139         /* Try for CRTL emulation of a Unix/POSIX name */
 140         else return getenv(lnm);
 141       }
 142     }
 143     return Nullch;
 144
 145 }  /* end of my_getenv() */
 146 /*}}}*/
 147
 148 /*{{{ void  my_setenv(char *lnm, char *eqv)*/
 149 void
 150 my_setenv(char *lnm,char *eqv)
 151 /* Define a supervisor-mode logical name in the process table.
 152  * In the future we'll add tables, attribs, and acmodes,
 153  * probably through a different call.
 154  */
 155 {
 156     char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
 157     unsigned long int retsts, usermode = PSL$C_USER;
 158     $DESCRIPTOR(tabdsc,"LNM$PROCESS");
 159     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 160                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 161
 162     for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
 163     lnmdsc.dsc$w_length = cp1 - lnm;
 164
 165     if (!eqv || !*eqv) {  /* we're deleting a logical name */
 166       retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
 167       if (retsts == SS$_IVLOGNAM) return;
 168       if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
 169       if (!(retsts & 1)) {
 170         retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
 171         if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
 172       }
 173     }
 174     else {
 175       eqvdsc.dsc$w_length = strlen(eqv);
 176       eqvdsc.dsc$a_pointer = eqv;
 177
 178       _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
 179     }
 180
 181 }  /* end of my_setenv() */
 182 /*}}}*/
 183
 184
 185 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
 186 /* my_crypt - VMS password hashing
 187  * my_crypt() provides an interface compatible with the Unix crypt()
 188  * C library function, and uses sys$hash_password() to perform VMS
 189  * password hashing.  The quadword hashed password value is returned
 190  * as a NUL-terminated 8 character string.  my_crypt() does not change
 191  * the case of its string arguments; in order to match the behavior
 192  * of LOGINOUT et al., alphabetic characters in both arguments must
 193  *  be upcased by the caller.
 194  */
 195 char *
 196 my_crypt(const char *textpasswd, const char *usrname)
 197 {
 198 #   ifndef UAI$C_PREFERRED_ALGORITHM
 199 #     define UAI$C_PREFERRED_ALGORITHM 127
 200 #   endif
 201     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
 202     unsigned short int salt = 0;
 203     unsigned long int sts;
 204     struct const_dsc {
 205         unsigned short int dsc$w_length;
 206         unsigned char      dsc$b_type;
 207         unsigned char      dsc$b_class;
 208         const char *       dsc$a_pointer;
 209     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
 210        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 211     struct itmlst_3 uailst[3] = {
 212         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
 213         { sizeof salt, UAI$_SALT,    &salt, 0},
 214         { 0,           0,            NULL,  NULL}};
 215     static char hash[9];
 216
 217     usrdsc.dsc$w_length = strlen(usrname);
 218     usrdsc.dsc$a_pointer = usrname;
 219     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
 220       switch (sts) {
 221         case SS$_NOGRPPRV:
 222         case SS$_NOSYSPRV:
 223           set_errno(EACCES);
 224           break;
 225         case RMS$_RNF:
 226           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
 227           break;
 228         default:
 229           set_errno(EVMSERR);
 230       }
 231       set_vaxc_errno(sts);
 232       if (sts != RMS$_RNF) return NULL;
 233     }
 234
 235     txtdsc.dsc$w_length = strlen(textpasswd);
 236     txtdsc.dsc$a_pointer = textpasswd;
 237     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
 238       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
 239     }
 240
 241     return (char *) hash;
 242
 243 }  /* end of my_crypt() */
 244 /*}}}*/
 245
 246
 247 static char *do_fileify_dirspec(char *, char *, int);
 248 static char *do_tovmsspec(char *, char *, int);
 249
 250 /*{{{int do_rmdir(char *name)*/
 251 int
 252 do_rmdir(char *name)
 253 {
 254     char dirfile[NAM$C_MAXRSS+1];
 255     int retval;
 256     struct stat st;
 257
 258     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
 259     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
 260     else retval = kill_file(dirfile);
 261     return retval;
 262
 263 }  /* end of do_rmdir */
 264 /*}}}*/
 265
 266 /* kill_file
 267  * Delete any file to which user has control access, regardless of whether
 268  * delete access is explicitly allowed.
 269  * Limitations: User must have write access to parent directory.
 270  *              Does not block signals or ASTs; if interrupted in midstream
 271  *              may leave file with an altered ACL.
 272  * HANDLE WITH CARE!
 273  */
 274 /*{{{int kill_file(char *name)*/
 275 int
 276 kill_file(char *name)
 277 {
 278     char vmsname[NAM$C_MAXRSS+1];
 279     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
 280     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
 281     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 282     struct myacedef {
 283       unsigned char myace$b_length;
 284       unsigned char myace$b_type;
 285       unsigned short int myace$w_flags;
 286       unsigned long int myace$l_access;
 287       unsigned long int myace$l_ident;
 288     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
 289                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
 290       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
 291      struct itmlst_3
 292        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
 293                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
 294        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
 295        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
 296        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
 297        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
 298
 299     if (!remove(name)) return 0;  /* Can we just get rid of it? */
 300
 301     /* No, so we get our own UIC to use as a rights identifier,
 302      * and the insert an ACE at the head of the ACL which allows us
 303      * to delete the file.
 304      */
 305     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
 306     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
 307     fildsc.dsc$w_length = strlen(vmsname);
 308     fildsc.dsc$a_pointer = vmsname;
 309     cxt = 0;
 310     newace.myace$l_ident = oldace.myace$l_ident;
 311     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
 312       set_errno(EVMSERR);
 313       set_vaxc_errno(aclsts);
 314       return -1;
 315     }
 316     /* Grab any existing ACEs with this identifier in case we fail */
 317     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
 318     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
 319                     || fndsts == SS$_NOMOREACE ) {
 320       /* Add the new ACE . . . */
 321       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
 322         goto yourroom;
 323       if ((rmsts = remove(name))) {
 324         /* We blew it - dir with files in it, no write priv for
 325          * parent directory, etc.  Put things back the way they were. */
 326         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
 327           goto yourroom;
 328         if (fndsts & 1) {
 329           addlst[0].bufadr = &oldace;
 330           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
 331             goto yourroom;
 332         }
 333       }
 334     }
 335
 336     yourroom:
 337     if (rmsts) {
 338       fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
 339       if (aclsts & 1) aclsts = fndsts;
 340     }
 341     if (!(aclsts & 1)) {
 342       set_errno(EVMSERR);
 343       set_vaxc_errno(aclsts);
 344       return -1;
 345     }
 346
 347     return rmsts;
 348
 349 }  /* end of kill_file() */
 350 /*}}}*/
 351
 352 /* my_utime - update modification time of a file
 353  * calling sequence is identical to POSIX utime(), but under
 354  * VMS only the modification time is changed; ODS-2 does not
 355  * maintain access times.  Restrictions differ from the POSIX
 356  * definition in that the time can be changed as long as the
 357  * caller has permission to execute the necessary IO$_MODIFY $QIO;
 358  * no separate checks are made to insure that the caller is the
 359  * owner of the file or has special privs enabled.
 360  * Code here is based on Joe Meadows' FILE utility.
 361  */
 362
 363 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
 364  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
 365  * in 100 ns intervals.
 366  */
 367 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
 368
 369 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
 370 int my_utime(char *file, struct utimbuf *utimes)
 371 {
 372   register int i;
 373   long int bintime[2], len = 2, lowbit, unixtime,
 374            secscale = 10000000; /* seconds --> 100 ns intervals */
 375   unsigned long int chan, iosb[2], retsts;
 376   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
 377   struct FAB myfab = cc$rms_fab;
 378   struct NAM mynam = cc$rms_nam;
 379 #if defined (__DECC) && defined (__VAX)
 380   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
 381    * at least through VMS V6.1, which causes a type-conversion warning.
 382    */
 383 #  pragma message save
 384 #  pragma message disable cvtdiftypes
 385 #endif
 386   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
 387   struct fibdef myfib;
 388 #if defined (__DECC) && defined (__VAX)
 389   /* This should be right after the declaration of myatr, but due
 390    * to a bug in VAX DEC C, this takes effect a statement early.
 391    */
 392 #  pragma message restore
 393 #endif
 394   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
 395                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
 396                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
 397
 398   if (file == NULL || *file == '\0') {
 399     set_errno(ENOENT);
 400     set_vaxc_errno(LIB$_INVARG);
 401     return -1;
 402   }
 403   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
 404
 405   if (utimes != NULL) {
 406     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
 407      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
 408      * Since time_t is unsigned long int, and lib$emul takes a signed long int
 409      * as input, we force the sign bit to be clear by shifting unixtime right
 410      * one bit, then multiplying by an extra factor of 2 in lib$emul().
 411      */
 412     lowbit = (utimes->modtime & 1) ? secscale : 0;
 413     unixtime = (long int) utimes->modtime;
 414     unixtime >> 1;  secscale << 1;
 415     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
 416     if (!(retsts & 1)) {
 417       set_errno(EVMSERR);
 418       set_vaxc_errno(retsts);
 419       return -1;
 420     }
 421     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
 422     if (!(retsts & 1)) {
 423       set_errno(EVMSERR);
 424       set_vaxc_errno(retsts);
 425       return -1;
 426     }
 427   }
 428   else {
 429     /* Just get the current time in VMS format directly */
 430     retsts = sys$gettim(bintime);
 431     if (!(retsts & 1)) {
 432       set_errno(EVMSERR);
 433       set_vaxc_errno(retsts);
 434       return -1;
 435     }
 436   }
 437
 438   myfab.fab$l_fna = vmsspec;
 439   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
 440   myfab.fab$l_nam = &mynam;
 441   mynam.nam$l_esa = esa;
 442   mynam.nam$b_ess = (unsigned char) sizeof esa;
 443   mynam.nam$l_rsa = rsa;
 444   mynam.nam$b_rss = (unsigned char) sizeof rsa;
 445
 446   /* Look for the file to be affected, letting RMS parse the file
 447    * specification for us as well.  I have set errno using only
 448    * values documented in the utime() man page for VMS POSIX.
 449    */
 450   retsts = sys$parse(&myfab,0,0);
 451   if (!(retsts & 1)) {
 452     set_vaxc_errno(retsts);
 453     if      (retsts == RMS$_PRV) set_errno(EACCES);
 454     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
 455     else                         set_errno(EVMSERR);
 456     return -1;
 457   }
 458   retsts = sys$search(&myfab,0,0);
 459   if (!(retsts & 1)) {
 460     set_vaxc_errno(retsts);
 461     if      (retsts == RMS$_PRV) set_errno(EACCES);
 462     else if (retsts == RMS$_FNF) set_errno(ENOENT);
 463     else                         set_errno(EVMSERR);
 464     return -1;
 465   }
 466
 467   devdsc.dsc$w_length = mynam.nam$b_dev;
 468   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
 469
 470   retsts = sys$assign(&devdsc,&chan,0,0);
 471   if (!(retsts & 1)) {
 472     set_vaxc_errno(retsts);
 473     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
 474     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
 475     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
 476     else                               set_errno(EVMSERR);
 477     return -1;
 478   }
 479
 480   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
 481   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
 482
 483   memset((void *) &myfib, 0, sizeof myfib);
 484 #ifdef __DECC
 485   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
 486   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
 487   /* This prevents the revision time of the file being reset to the current
 488    * time as a result of our IO$_MODIFY $QIO. */
 489   myfib.fib$l_acctl = FIB$M_NORECORD;
 490 #else
 491   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
 492   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
 493   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
 494 #endif
 495   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
 496   _ckvmssts(sys$dassgn(chan));
 497   if (retsts & 1) retsts = iosb[0];
 498   if (!(retsts & 1)) {
 499     set_vaxc_errno(retsts);
 500     if (retsts == SS$_NOPRIV) set_errno(EACCES);
 501     else                      set_errno(EVMSERR);
 502     return -1;
 503   }
 504
 505   return 0;
 506 }  /* end of my_utime() */
 507 /*}}}*/
 508
 509 static void
 510 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
 511 {
 512   static unsigned long int mbxbufsiz;
 513   long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 514
 515   if (!mbxbufsiz) {
 516     /*
 517      * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
 518      * preprocessor consant BUFSIZ from stdio.h as the size of the
 519      * 'pipe' mailbox.
 520      */
 521     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 522     if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
 523   }
 524   _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
 525
 526   _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
 527   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
 528
 529 }  /* end of create_mbx() */
 530
 531 /*{{{  my_popen and my_pclose*/
 532 struct pipe_details
 533 {
 534     struct pipe_details *next;
 535     FILE *fp;  /* stdio file pointer to pipe mailbox */
 536     int pid;   /* PID of subprocess */
 537     int mode;  /* == 'r' if pipe open for reading */
 538     int done;  /* subprocess has completed */
 539     unsigned long int completion;  /* termination status of subprocess */
 540 };
 541
 542 struct exit_control_block
 543 {
 544     struct exit_control_block *flink;
 545     unsigned long int   (*exit_routine)();
 546     unsigned long int arg_count;
 547     unsigned long int *status_address;
 548     unsigned long int exit_status;
 549 };
 550
 551 static struct pipe_details *open_pipes = NULL;
 552 static $DESCRIPTOR(nl_desc, "NL:");
 553 static int waitpid_asleep = 0;
 554
 555 static unsigned long int
 556 pipe_exit_routine()
 557 {
 558     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
 559
 560     while (open_pipes != NULL) {
 561       if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
 562         _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
 563         sleep(1);
 564       }
 565       if (!open_pipes->done)  /* We tried to be nice . . . */
 566         _ckvmssts(sys$delprc(&open_pipes->pid,0));
 567       if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
 568     }
 569     return retsts;
 570 }
 571
 572 static struct exit_control_block pipe_exitblock =
 573        {(struct exit_control_block *) 0,
 574         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
 575
 576
 577 static void
 578 popen_completion_ast(struct pipe_details *thispipe)
 579 {
 580   thispipe->done = TRUE;
 581   if (waitpid_asleep) {
 582     waitpid_asleep = 0;
 583     sys$wake(0,0);
 584   }
 585 }
 586
 587 /*{{{  FILE *my_popen(char *cmd, char *mode)*/
 588 FILE *
 589 my_popen(char *cmd, char *mode)
 590 {
 591     static int handler_set_up = FALSE;
 592     char mbxname[64];
 593     unsigned short int chan;
 594     unsigned long int flags=1;  /* nowait - gnu c doesn't allow &1 */
 595     struct pipe_details *info;
 596     struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
 597                                       DSC$K_CLASS_S, mbxname},
 598                             cmddsc = {0, DSC$K_DTYPE_T,
 599                                       DSC$K_CLASS_S, 0};
 600
 601
 602     cmddsc.dsc$w_length=strlen(cmd);
 603     cmddsc.dsc$a_pointer=cmd;
 604     if (cmddsc.dsc$w_length > 255) {
 605       set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
 606       return Nullfp;
 607     }
 608
 609     New(7001,info,1,struct pipe_details);
 610
 611     /* create mailbox */
 612     create_mbx(&chan,&namdsc);
 613
 614     /* open a FILE* onto it */
 615     info->fp=fopen(mbxname, mode);
 616
 617     /* give up other channel onto it */
 618     _ckvmssts(sys$dassgn(chan));
 619
 620     if (!info->fp)
 621         return Nullfp;
 622
 623     info->mode = *mode;
 624     info->done = FALSE;
 625     info->completion=0;
 626
 627     if (*mode == 'r') {
 628       _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
 629                      0  /* name */, &info->pid, &info->completion,
 630                      0, popen_completion_ast,info,0,0,0));
 631     }
 632     else {
 633       _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
 634                      0  /* name */, &info->pid, &info->completion,
 635                      0, popen_completion_ast,info,0,0,0));
 636     }
 637
 638     if (!handler_set_up) {
 639       _ckvmssts(sys$dclexh(&pipe_exitblock));
 640       handler_set_up = TRUE;
 641     }
 642     info->next=open_pipes;  /* prepend to list */
 643     open_pipes=info;
 644
 645     forkprocess = info->pid;
 646     return info->fp;
 647 }
 648 /*}}}*/
 649
 650 /*{{{  I32 my_pclose(FILE *fp)*/
 651 I32 my_pclose(FILE *fp)
 652 {
 653     struct pipe_details *info, *last = NULL;
 654     unsigned long int retsts;
 655
 656     for (info = open_pipes; info != NULL; last = info, info = info->next)
 657         if (info->fp == fp) break;
 658
 659     if (info == NULL)
 660       /* get here => no such pipe open */
 661       croak("No such pipe open");
 662
 663     fclose(info->fp);
 664
 665     if (info->done) retsts = info->completion;
 666     else waitpid(info->pid,(int *) &retsts,0);
 667
 668     /* remove from list of open pipes */
 669     if (last) last->next = info->next;
 670     else open_pipes = info->next;
 671     Safefree(info);
 672
 673     return retsts;
 674
 675 }  /* end of my_pclose() */
 676
 677 /* sort-of waitpid; use only with popen() */
 678 /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
 679 unsigned long int
 680 waitpid(unsigned long int pid, int *statusp, int flags)
 681 {
 682     struct pipe_details *info;
 683
 684     for (info = open_pipes; info != NULL; info = info->next)
 685         if (info->pid == pid) break;
 686
 687     if (info != NULL) {  /* we know about this child */
 688       while (!info->done) {
 689         waitpid_asleep = 1;
 690         sys$hiber();
 691       }
 692
 693       *statusp = info->completion;
 694       return pid;
 695     }
 696     else {  /* we haven't heard of this child */
 697       $DESCRIPTOR(intdsc,"0 00:00:01");
 698       unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
 699       unsigned long int interval[2],sts;
 700
 701       if (dowarn) {
 702         _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
 703         _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
 704         if (ownerpid != mypid)
 705           warn("pid %d not a child",pid);
 706       }
 707
 708       _ckvmssts(sys$bintim(&intdsc,interval));
 709       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
 710         _ckvmssts(sys$schdwk(0,0,interval,0));
 711         _ckvmssts(sys$hiber());
 712       }
 713       _ckvmssts(sts);
 714
 715       /* There's no easy way to find the termination status a child we're
 716        * not aware of beforehand.  If we're really interested in the future,
 717        * we can go looking for a termination mailbox, or chase after the
 718        * accounting record for the process.
 719        */
 720       *statusp = 0;
 721       return pid;
 722     }
 723
 724 }  /* end of waitpid() */
 725 /*}}}*/
 726 /*}}}*/
 727 /*}}}*/
 728
 729 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
 730 char *
 731 my_gconvert(double val, int ndig, int trail, char *buf)
 732 {
 733   static char __gcvtbuf[DBL_DIG+1];
 734   char *loc;
 735
 736   loc = buf ? buf : __gcvtbuf;
 737   if (val) {
 738     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
 739     return gcvt(val,ndig,loc);
 740   }
 741   else {
 742     loc[0] = '0'; loc[1] = '\0';
 743     return loc;
 744   }
 745
 746 }
 747 /*}}}*/
 748
 749 /*
 750 ** The following routines are provided to make life easier when
 751 ** converting among VMS-style and Unix-style directory specifications.
 752 ** All will take input specifications in either VMS or Unix syntax. On
 753 ** failure, all return NULL.  If successful, the routines listed below
 754 ** return a pointer to a buffer containing the appropriately
 755 ** reformatted spec (and, therefore, subsequent calls to that routine
 756 ** will clobber the result), while the routines of the same names with
 757 ** a _ts suffix appended will return a pointer to a mallocd string
 758 ** containing the appropriately reformatted spec.
 759 ** In all cases, only explicit syntax is altered; no check is made that
 760 ** the resulting string is valid or that the directory in question
 761 ** actually exists.
 762 **
 763 **   fileify_dirspec() - convert a directory spec into the name of the
 764 **     directory file (i.e. what you can stat() to see if it's a dir).
 765 **     The style (VMS or Unix) of the result is the same as the style
 766 **     of the parameter passed in.
 767 **   pathify_dirspec() - convert a directory spec into a path (i.e.
 768 **     what you prepend to a filename to indicate what directory it's in).
 769 **     The style (VMS or Unix) of the result is the same as the style
 770 **     of the parameter passed in.
 771 **   tounixpath() - convert a directory spec into a Unix-style path.
 772 **   tovmspath() - convert a directory spec into a VMS-style path.
 773 **   tounixspec() - convert any file spec into a Unix-style file spec.
 774 **   tovmsspec() - convert any file spec into a VMS-style spec.
 775 **
 776 ** Copyright 1996 by Charles Bailey  <bailey@genetics.upenn.edu>
 777 ** Permission is given to distribute this code as part of the Perl
 778 ** standard distribution under the terms of the GNU General Public
 779 ** License or the Perl Artistic License.  Copies of each may be
 780 ** found in the Perl standard distribution.
 781  */
 782
 783 static char *do_tounixspec(char *, char *, int);
 784
 785 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
 786 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
 787 {
 788     static char __fileify_retbuf[NAM$C_MAXRSS+1];
 789     unsigned long int dirlen, retlen, addmfd = 0;
 790     char *retspec, *cp1, *cp2, *lastdir;
 791     char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
 792
 793     if (!dir || !*dir) {
 794       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
 795     }
 796     dirlen = strlen(dir);
 797     if (dir[dirlen-1] == '/') --dirlen;
 798     if (!dirlen) {
 799       set_errno(ENOTDIR);
 800       set_vaxc_errno(RMS$_DIR);
 801       return NULL;
 802     }
 803     if (!strpbrk(dir+1,"/]>:")) {
 804       strcpy(trndir,*dir == '/' ? dir + 1: dir);
 805       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
 806       dir = trndir;
 807       dirlen = strlen(dir);
 808     }
 809     else {
 810       strncpy(trndir,dir,dirlen);
 811       trndir[dirlen] = '\0';
 812       dir = trndir;
 813     }
 814     /* If we were handed a rooted logical name or spec, treat it like a
 815      * simple directory, so that
 816      *    $ Define myroot dev:[dir.]
 817      *    ... do_fileify_dirspec("myroot",buf,1) ...
 818      * does something useful.
 819      */
 820     if (!strcmp(dir+dirlen-2,".]")) {
 821       dir[--dirlen] = '\0';
 822       dir[dirlen-1] = ']';
 823     }
 824
 825     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
 826       if (dir[0] == '.') {
 827         if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
 828           return do_fileify_dirspec("[]",buf,ts);
 829         else if (dir[1] == '.' &&
 830                  (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
 831           return do_fileify_dirspec("[-]",buf,ts);
 832       }
 833       if (dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
 834         dirlen -= 1;                 /* to last element */
 835         lastdir = strrchr(dir,'/');
 836       }
 837       else if ((cp1 = strstr(dir,"/.")) != NULL) {
 838         /* If we have "/." or "/..", VMSify it and let the VMS code
 839          * below expand it, rather than repeating the code to handle
 840          * relative components of a filespec here */
 841         do {
 842           if (*(cp1+2) == '.') cp1++;
 843           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
 844             if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
 845             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
 846             return do_tounixspec(trndir,buf,ts);
 847           }
 848           cp1++;
 849         } while ((cp1 = strstr(cp1,"/.")) != NULL);
 850       }
 851       else {
 852         if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
 853         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
 854           if (toupper(*(cp2+1)) == 'D' &&    /* Yep.  Is it .dir? */
 855               toupper(*(cp2+2)) == 'I' &&
 856               toupper(*(cp2+3)) == 'R') {
 857             if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
 858               if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
 859                 set_errno(ENOTDIR);                      /* Bzzt. */
 860                 set_vaxc_errno(RMS$_DIR);
 861                 return NULL;
 862               }
 863             }
 864             dirlen = cp2 - dir;
 865           }
 866           else {   /* There's a type, and it's not .dir.  Bzzt. */
 867             set_errno(ENOTDIR);
 868             set_vaxc_errno(RMS$_DIR);
 869             return NULL;
 870           }
 871         }
 872       }
 873       /* If we lead off with a device or rooted logical, add the MFD
 874          if we're specifying a top-level directory. */
 875       if (lastdir && *dir == '/') {
 876         addmfd = 1;
 877         for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
 878           if (*cp1 == '/') {
 879             addmfd = 0;
 880             break;
 881           }
 882         }
 883       }
 884       retlen = dirlen + (addmfd ? 13 : 6);
 885       if (buf) retspec = buf;
 886       else if (ts) New(7009,retspec,retlen+1,char);
 887       else retspec = __fileify_retbuf;
 888       if (addmfd) {
 889         dirlen = lastdir - dir;
 890         memcpy(retspec,dir,dirlen);
 891         strcpy(&retspec[dirlen],"/000000");
 892         strcpy(&retspec[dirlen+7],lastdir);
 893       }
 894       else {
 895         memcpy(retspec,dir,dirlen);
 896         retspec[dirlen] = '\0';
 897       }
 898       /* We've picked up everything up to the directory file name.
 899          Now just add the type and version, and we're set. */
 900       strcat(retspec,".dir;1");
 901       return retspec;
 902     }
 903     else {  /* VMS-style directory spec */
 904       char esa[NAM$C_MAXRSS+1], term, *cp;
 905       unsigned long int sts, cmplen, haslower = 0;
 906       struct FAB dirfab = cc$rms_fab;
 907       struct NAM savnam, dirnam = cc$rms_nam;
 908
 909       dirfab.fab$b_fns = strlen(dir);
 910       dirfab.fab$l_fna = dir;
 911       dirfab.fab$l_nam = &dirnam;
 912       dirfab.fab$l_dna = ".DIR;1";
 913       dirfab.fab$b_dns = 6;
 914       dirnam.nam$b_ess = NAM$C_MAXRSS;
 915       dirnam.nam$l_esa = esa;
 916
 917       for (cp = dir; *cp; cp++)
 918         if (islower(*cp)) { haslower = 1; break; }
 919       if (!((sts = sys$parse(&dirfab))&1)) {
 920         if (dirfab.fab$l_sts == RMS$_DIR) {
 921           dirnam.nam$b_nop |= NAM$M_SYNCHK;
 922           sts = sys$parse(&dirfab) & 1;
 923         }
 924         if (!sts) {
 925           set_errno(EVMSERR);
 926           set_vaxc_errno(dirfab.fab$l_sts);
 927           return NULL;
 928         }
 929       }
 930       else {
 931         savnam = dirnam;
 932         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
 933           /* Yes; fake the fnb bits so we'll check type below */
 934           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
 935         }
 936         else {
 937           if (dirfab.fab$l_sts != RMS$_FNF) {
 938             set_errno(EVMSERR);
 939             set_vaxc_errno(dirfab.fab$l_sts);
 940             return NULL;
 941           }
 942           dirnam = savnam; /* No; just work with potential name */
 943         }
 944       }
 945       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
 946         cp1 = strchr(esa,']');
 947         if (!cp1) cp1 = strchr(esa,'>');
 948         if (cp1) {  /* Should always be true */
 949           dirnam.nam$b_esl -= cp1 - esa - 1;
 950           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
 951         }
 952       }
 953       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
 954         /* Yep; check version while we're at it, if it's there. */
 955         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
 956         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
 957           /* Something other than .DIR[;1].  Bzzt. */
 958           set_errno(ENOTDIR);
 959           set_vaxc_errno(RMS$_DIR);
 960           return NULL;
 961         }
 962       }
 963       esa[dirnam.nam$b_esl] = '\0';
 964       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
 965         /* They provided at least the name; we added the type, if necessary, */
 966         if (buf) retspec = buf;                            /* in sys$parse() */
 967         else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
 968         else retspec = __fileify_retbuf;
 969         strcpy(retspec,esa);
 970         return retspec;
 971       }
 972       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
 973         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
 974         *cp1 = '\0';
 975         dirnam.nam$b_esl -= 9;
 976       }
 977       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
 978       if (cp1 == NULL) return NULL; /* should never happen */
 979       term = *cp1;
 980       *cp1 = '\0';
 981       retlen = strlen(esa);
 982       if ((cp1 = strrchr(esa,'.')) != NULL) {
 983         /* There's more than one directory in the path.  Just roll back. */
 984         *cp1 = term;
 985         if (buf) retspec = buf;
 986         else if (ts) New(7011,retspec,retlen+7,char);
 987         else retspec = __fileify_retbuf;
 988         strcpy(retspec,esa);
 989       }
 990       else {
 991         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
 992           /* Go back and expand rooted logical name */
 993           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
 994           if (!(sys$parse(&dirfab) & 1)) {
 995             set_errno(EVMSERR);
 996             set_vaxc_errno(dirfab.fab$l_sts);
 997             return NULL;
 998           }
 999           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1000           if (buf) retspec = buf;
1001           else if (ts) New(7012,retspec,retlen+16,char);
1002           else retspec = __fileify_retbuf;
1003           cp1 = strstr(esa,"][");
1004           dirlen = cp1 - esa;
1005           memcpy(retspec,esa,dirlen);
1006           if (!strncmp(cp1+2,"000000]",7)) {
1007             retspec[dirlen-1] = '\0';
1008             for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1009             if (*cp1 == '.') *cp1 = ']';
1010             else {
1011               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1012               memcpy(cp1+1,"000000]",7);
1013             }
1014           }
1015           else {
1016             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1017             retspec[retlen] = '\0';
1018             /* Convert last '.' to ']' */
1019             for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1020             if (*cp1 == '.') *cp1 = ']';
1021             else {
1022               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1023               memcpy(cp1+1,"000000]",7);
1024             }
1025           }
1026         }
1027         else {  /* This is a top-level dir.  Add the MFD to the path. */
1028           if (buf) retspec = buf;
1029           else if (ts) New(7012,retspec,retlen+16,char);
1030           else retspec = __fileify_retbuf;
1031           cp1 = esa;
1032           cp2 = retspec;
1033           while (*cp1 != ':') *(cp2++) = *(cp1++);
1034           strcpy(cp2,":[000000]");
1035           cp1 += 2;
1036           strcpy(cp2+9,cp1);
1037         }
1038       }
1039       /* We've set up the string up through the filename.  Add the
1040          type and version, and we're done. */
1041       strcat(retspec,".DIR;1");
1042
1043       /* $PARSE may have upcased filespec, so convert output to lower
1044        * case if input contained any lowercase characters. */
1045       if (haslower) __mystrtolower(retspec);
1046       return retspec;
1047     }
1048 }  /* end of do_fileify_dirspec() */
1049 /*}}}*/
1050 /* External entry points */
1051 char *fileify_dirspec(char *dir, char *buf)
1052 { return do_fileify_dirspec(dir,buf,0); }
1053 char *fileify_dirspec_ts(char *dir, char *buf)
1054 { return do_fileify_dirspec(dir,buf,1); }
1055
1056 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1057 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1058 {
1059     static char __pathify_retbuf[NAM$C_MAXRSS+1];
1060     unsigned long int retlen;
1061     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1062
1063     if (!dir || !*dir) {
1064       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1065     }
1066
1067     if (*dir) strcpy(trndir,dir);
1068     else getcwd(trndir,sizeof trndir - 1);
1069
1070     while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1071       STRLEN trnlen = strlen(trndir);
1072
1073       /* Trap simple rooted lnms, and return lnm:[000000] */
1074       if (!strcmp(trndir+trnlen-2,".]")) {
1075         if (buf) retpath = buf;
1076         else if (ts) New(7018,retpath,strlen(dir)+10,char);
1077         else retpath = __pathify_retbuf;
1078         strcpy(retpath,dir);
1079         strcat(retpath,":[000000]");
1080         return retpath;
1081       }
1082     }
1083     dir = trndir;
1084
1085     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
1086       if (*dir == '.' && (*(dir+1) == '\0' ||
1087                           (*(dir+1) == '.' && *(dir+2) == '\0')))
1088         retlen = 2 + (*(dir+1) != '\0');
1089       else {
1090         if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
1091         if ((cp2 = strchr(cp1,'.')) && (*(cp2+1) != '.' && *(cp2+1) != '\0')) {
1092           if (toupper(*(cp2+1)) == 'D' &&  /* They specified .dir. */
1093               toupper(*(cp2+2)) == 'I' &&  /* Trim it off. */
1094               toupper(*(cp2+3)) == 'R') {
1095             retlen = cp2 - dir + 1;
1096           }
1097           else {  /* Some other file type.  Bzzt. */
1098             set_errno(ENOTDIR);
1099             set_vaxc_errno(RMS$_DIR);
1100             return NULL;
1101           }
1102         }
1103         else {  /* No file type present.  Treat the filename as a directory. */
1104           retlen = strlen(dir) + 1;
1105         }
1106       }
1107       if (buf) retpath = buf;
1108       else if (ts) New(7013,retpath,retlen+1,char);
1109       else retpath = __pathify_retbuf;
1110       strncpy(retpath,dir,retlen-1);
1111       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1112         retpath[retlen-1] = '/';      /* with '/', add it. */
1113         retpath[retlen] = '\0';
1114       }
1115       else retpath[retlen-1] = '\0';
1116     }
1117     else {  /* VMS-style directory spec */
1118       char esa[NAM$C_MAXRSS+1], *cp;
1119       unsigned long int sts, cmplen, haslower;
1120       struct FAB dirfab = cc$rms_fab;
1121       struct NAM savnam, dirnam = cc$rms_nam;
1122
1123       dirfab.fab$b_fns = strlen(dir);
1124       dirfab.fab$l_fna = dir;
1125       if (dir[dirfab.fab$b_fns-1] == ']' ||
1126           dir[dirfab.fab$b_fns-1] == '>' ||
1127           dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1128         if (buf) retpath = buf;
1129         else if (ts) New(7014,retpath,strlen(dir)+1,char);
1130         else retpath = __pathify_retbuf;
1131         strcpy(retpath,dir);
1132         return retpath;
1133       }
1134       dirfab.fab$l_dna = ".DIR;1";
1135       dirfab.fab$b_dns = 6;
1136       dirfab.fab$l_nam = &dirnam;
1137       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1138       dirnam.nam$l_esa = esa;
1139
1140       for (cp = dir; *cp; cp++)
1141         if (islower(*cp)) { haslower = 1; break; }
1142
1143       if (!(sts = (sys$parse(&dirfab)&1))) {
1144         if (dirfab.fab$l_sts == RMS$_DIR) {
1145           dirnam.nam$b_nop |= NAM$M_SYNCHK;
1146           sts = sys$parse(&dirfab) & 1;
1147         }
1148         if (!sts) {
1149           set_errno(EVMSERR);
1150           set_vaxc_errno(dirfab.fab$l_sts);
1151           return NULL;
1152         }
1153       }
1154       else {
1155         savnam = dirnam;
1156         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
1157           if (dirfab.fab$l_sts != RMS$_FNF) {
1158             set_errno(EVMSERR);
1159             set_vaxc_errno(dirfab.fab$l_sts);
1160             return NULL;
1161           }
1162           dirnam = savnam; /* No; just work with potential name */
1163         }
1164       }
1165       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
1166         /* Yep; check version while we're at it, if it's there. */
1167         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1168         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1169           /* Something other than .DIR[;1].  Bzzt. */
1170           set_errno(ENOTDIR);
1171           set_vaxc_errno(RMS$_DIR);
1172           return NULL;
1173         }
1174       }
1175       /* OK, the type was fine.  Now pull any file name into the
1176          directory path. */
1177       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1178       else {
1179         cp1 = strrchr(esa,'>');
1180         *dirnam.nam$l_type = '>';
1181       }
1182       *cp1 = '.';
1183       *(dirnam.nam$l_type + 1) = '\0';
1184       retlen = dirnam.nam$l_type - esa + 2;
1185       if (buf) retpath = buf;
1186       else if (ts) New(7014,retpath,retlen,char);
1187       else retpath = __pathify_retbuf;
1188       strcpy(retpath,esa);
1189       /* $PARSE may have upcased filespec, so convert output to lower
1190        * case if input contained any lowercase characters. */
1191       if (haslower) __mystrtolower(retpath);
1192     }
1193
1194     return retpath;
1195 }  /* end of do_pathify_dirspec() */
1196 /*}}}*/
1197 /* External entry points */
1198 char *pathify_dirspec(char *dir, char *buf)
1199 { return do_pathify_dirspec(dir,buf,0); }
1200 char *pathify_dirspec_ts(char *dir, char *buf)
1201 { return do_pathify_dirspec(dir,buf,1); }
1202
1203 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1204 static char *do_tounixspec(char *spec, char *buf, int ts)
1205 {
1206   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1207   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1208   int devlen, dirlen, retlen = NAM$C_MAXRSS+1, dashes = 0;
1209
1210   if (spec == NULL) return NULL;
1211   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1212   if (buf) rslt = buf;
1213   else if (ts) {
1214     retlen = strlen(spec);
1215     cp1 = strchr(spec,'[');
1216     if (!cp1) cp1 = strchr(spec,'<');
1217     if (cp1) {
1218       for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS  '-' ==> Unix '../' */
1219     }
1220     New(7015,rslt,retlen+2+2*dashes,char);
1221   }
1222   else rslt = __tounixspec_retbuf;
1223   if (strchr(spec,'/') != NULL) {
1224     strcpy(rslt,spec);
1225     return rslt;
1226   }
1227
1228   cp1 = rslt;
1229   cp2 = spec;
1230   dirend = strrchr(spec,']');
1231   if (dirend == NULL) dirend = strrchr(spec,'>');
1232   if (dirend == NULL) dirend = strchr(spec,':');
1233   if (dirend == NULL) {
1234     strcpy(rslt,spec);
1235     return rslt;
1236   }
1237   if (*cp2 != '[' && *cp2 != '<') {
1238     *(cp1++) = '/';
1239   }
1240   else {  /* the VMS spec begins with directories */
1241     cp2++;
1242     if (*cp2 == ']' || *cp2 == '>') {
1243       strcpy(rslt,"./");
1244       return rslt;
1245     }
1246     else if ( *cp2 != '.' && *cp2 != '-') {
1247       *(cp1++) = '/';           /* add the implied device into the Unix spec */
1248       if (getcwd(tmp,sizeof tmp,1) == NULL) {
1249         if (ts) Safefree(rslt);
1250         return NULL;
1251       }
1252       do {
1253         cp3 = tmp;
1254         while (*cp3 != ':' && *cp3) cp3++;
1255         *(cp3++) = '\0';
1256         if (strchr(cp3,']') != NULL) break;
1257       } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1258       cp3 = tmp;
1259       while (*cp3) *(cp1++) = *(cp3++);
1260       *(cp1++) = '/';
1261       if (ts &&
1262           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1263         int offset = cp1 - rslt;
1264
1265         retlen = devlen + dirlen;
1266         Renew(rslt,retlen+1+2*dashes,char);
1267         cp1 = rslt + offset;
1268       }
1269     }
1270     else if (*cp2 == '.') cp2++;
1271   }
1272   for (; cp2 <= dirend; cp2++) {
1273     if (*cp2 == ':') {
1274       *(cp1++) = '/';
1275       if (*(cp2+1) == '[') cp2++;
1276     }
1277     else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
1278     else if (*cp2 == '.') {
1279       *(cp1++) = '/';
1280       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1281         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1282                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1283         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1284             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1285       }
1286     }
1287     else if (*cp2 == '-') {
1288       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1289         while (*cp2 == '-') {
1290           cp2++;
1291           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1292         }
1293         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1294           if (ts) Safefree(rslt);                        /* filespecs like */
1295           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
1296           return NULL;
1297         }
1298       }
1299       else *(cp1++) = *cp2;
1300     }
1301     else *(cp1++) = *cp2;
1302   }
1303   while (*cp2) *(cp1++) = *(cp2++);
1304   *cp1 = '\0';
1305
1306   return rslt;
1307
1308 }  /* end of do_tounixspec() */
1309 /*}}}*/
1310 /* External entry points */
1311 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1312 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1313
1314 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1315 static char *do_tovmsspec(char *path, char *buf, int ts) {
1316   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1317   char *rslt, *dirend;
1318   register char *cp1, *cp2;
1319   unsigned long int infront = 0, hasdir = 1;
1320
1321   if (path == NULL) return NULL;
1322   if (buf) rslt = buf;
1323   else if (ts) New(7016,rslt,strlen(path)+9,char);
1324   else rslt = __tovmsspec_retbuf;
1325   if (strpbrk(path,"]:>") ||
1326       (dirend = strrchr(path,'/')) == NULL) {
1327     if (path[0] == '.') {
1328       if (path[1] == '\0') strcpy(rslt,"[]");
1329       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1330       else strcpy(rslt,path); /* probably garbage */
1331     }
1332     else strcpy(rslt,path);
1333     return rslt;
1334   }
1335   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.."? */
1336     if (!*(dirend+2)) dirend +=2;
1337     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1338   }
1339   cp1 = rslt;
1340   cp2 = path;
1341   if (*cp2 == '/') {
1342     char trndev[NAM$C_MAXRSS+1];
1343     int islnm, rooted;
1344     STRLEN trnend;
1345
1346     while (*(++cp2) == '/') ;  /* Skip multiple /s */
1347     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1348     *cp1 = '\0';
1349     islnm =  my_trnlnm(rslt,trndev,0);
1350     trnend = islnm ? strlen(trndev) - 1 : 0;
1351     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1352     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1353     /* If the first element of the path is a logical name, determine
1354      * whether it has to be translated so we can add more directories. */
1355     if (!islnm || rooted) {
1356       *(cp1++) = ':';
1357       *(cp1++) = '[';
1358       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1359       else cp2++;
1360     }
1361     else {
1362       if (cp2 != dirend) {
1363         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1364         strcpy(rslt,trndev);
1365         cp1 = rslt + trnend;
1366         *(cp1++) = '.';
1367         cp2++;
1368       }
1369       else {
1370         *(cp1++) = ':';
1371         hasdir = 0;
1372       }
1373     }
1374   }
1375   else {
1376     *(cp1++) = '[';
1377     if (*cp2 == '.') {
1378       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1379         cp2 += 2;         /* skip over "./" - it's redundant */
1380         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
1381       }
1382       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1383         *(cp1++) = '-';                                 /* "../" --> "-" */
1384         cp2 += 3;
1385       }
1386       if (cp2 > dirend) cp2 = dirend;
1387     }
1388     else *(cp1++) = '.';
1389   }
1390   for (; cp2 < dirend; cp2++) {
1391     if (*cp2 == '/') {
1392       if (*(cp2-1) == '/') continue;
1393       if (*(cp1-1) != '.') *(cp1++) = '.';
1394       infront = 0;
1395     }
1396     else if (!infront && *cp2 == '.') {
1397       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1398       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
1399       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1400         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1401         else if (*(cp1-2) == '[') *(cp1-1) = '-';
1402         else {  /* back up over previous directory name */
1403           cp1--;
1404           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1405           if (*(cp1-1) == '[') {
1406             memcpy(cp1,"000000.",7);
1407             cp1 += 7;
1408           }
1409         }
1410         cp2 += 2;
1411         if (cp2 == dirend) break;
1412       }
1413       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
1414     }
1415     else {
1416       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
1417       if (*cp2 == '.')      *(cp1++) = '_';
1418       else                  *(cp1++) =  *cp2;
1419       infront = 1;
1420     }
1421   }
1422   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1423   if (hasdir) *(cp1++) = ']';
1424   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
1425   while (*cp2) *(cp1++) = *(cp2++);
1426   *cp1 = '\0';
1427
1428   return rslt;
1429
1430 }  /* end of do_tovmsspec() */
1431 /*}}}*/
1432 /* External entry points */
1433 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1434 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1435
1436 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1437 static char *do_tovmspath(char *path, char *buf, int ts) {
1438   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1439   int vmslen;
1440   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1441
1442   if (path == NULL) return NULL;
1443   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1444   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1445   if (buf) return buf;
1446   else if (ts) {
1447     vmslen = strlen(vmsified);
1448     New(7017,cp,vmslen+1,char);
1449     memcpy(cp,vmsified,vmslen);
1450     cp[vmslen] = '\0';
1451     return cp;
1452   }
1453   else {
1454     strcpy(__tovmspath_retbuf,vmsified);
1455     return __tovmspath_retbuf;
1456   }
1457
1458 }  /* end of do_tovmspath() */
1459 /*}}}*/
1460 /* External entry points */
1461 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1462 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1463
1464
1465 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1466 static char *do_tounixpath(char *path, char *buf, int ts) {
1467   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1468   int unixlen;
1469   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1470
1471   if (path == NULL) return NULL;
1472   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1473   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1474   if (buf) return buf;
1475   else if (ts) {
1476     unixlen = strlen(unixified);
1477     New(7017,cp,unixlen+1,char);
1478     memcpy(cp,unixified,unixlen);
1479     cp[unixlen] = '\0';
1480     return cp;
1481   }
1482   else {
1483     strcpy(__tounixpath_retbuf,unixified);
1484     return __tounixpath_retbuf;
1485   }
1486
1487 }  /* end of do_tounixpath() */
1488 /*}}}*/
1489 /* External entry points */
1490 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1491 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1492
1493 /*
1494  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
1495  *
1496  *****************************************************************************
1497  *                                                                           *
1498  *  Copyright (C) 1989-1994 by                                               *
1499  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
1500  *                                                                           *
1501  *  Permission is hereby  granted for the reproduction of this software,     *
1502  *  on condition that this copyright notice is included in the reproduction, *
1503  *  and that such reproduction is not for purposes of profit or material     *
1504  *  gain.                                                                    *
1505  *                                                                           *
1506  *  27-Aug-1994 Modified for inclusion in perl5                              *
1507  *              by Charles Bailey  bailey@genetics.upenn.edu                 *
1508  *****************************************************************************
1509  */
1510
1511 /*
1512  * getredirection() is intended to aid in porting C programs
1513  * to VMS (Vax-11 C).  The native VMS environment does not support
1514  * '>' and '<' I/O redirection, or command line wild card expansion,
1515  * or a command line pipe mechanism using the '|' AND background
1516  * command execution '&'.  All of these capabilities are provided to any
1517  * C program which calls this procedure as the first thing in the
1518  * main program.
1519  * The piping mechanism will probably work with almost any 'filter' type
1520  * of program.  With suitable modification, it may useful for other
1521  * portability problems as well.
1522  *
1523  * Author:  Mark Pizzolato      mark@infocomm.com
1524  */
1525 struct list_item
1526     {
1527     struct list_item *next;
1528     char *value;
1529     };
1530
1531 static void add_item(struct list_item **head,
1532                      struct list_item **tail,
1533                      char *value,
1534                      int *count);
1535
1536 static void expand_wild_cards(char *item,
1537                               struct list_item **head,
1538                               struct list_item **tail,
1539                               int *count);
1540
1541 static int background_process(int argc, char **argv);
1542
1543 static void pipe_and_fork(char **cmargv);
1544
1545 /*{{{ void getredirection(int *ac, char ***av)*/
1546 void
1547 getredirection(int *ac, char ***av)
1548 /*
1549  * Process vms redirection arg's.  Exit if any error is seen.
1550  * If getredirection() processes an argument, it is erased
1551  * from the vector.  getredirection() returns a new argc and argv value.
1552  * In the event that a background command is requested (by a trailing "&"),
1553  * this routine creates a background subprocess, and simply exits the program.
1554  *
1555  * Warning: do not try to simplify the code for vms.  The code
1556  * presupposes that getredirection() is called before any data is
1557  * read from stdin or written to stdout.
1558  *
1559  * Normal usage is as follows:
1560  *
1561  *      main(argc, argv)
1562  *      int             argc;
1563  *      char            *argv[];
1564  *      {
1565  *              getredirection(&argc, &argv);
1566  *      }
1567  */
1568 {
1569     int                 argc = *ac;     /* Argument Count         */
1570     char                **argv = *av;   /* Argument Vector        */
1571     char                *ap;            /* Argument pointer       */
1572     int                 j;              /* argv[] index           */
1573     int                 item_count = 0; /* Count of Items in List */
1574     struct list_item    *list_head = 0; /* First Item in List       */
1575     struct list_item    *list_tail;     /* Last Item in List        */
1576     char                *in = NULL;     /* Input File Name          */
1577     char                *out = NULL;    /* Output File Name         */
1578     char                *outmode = "w"; /* Mode to Open Output File */
1579     char                *err = NULL;    /* Error File Name          */
1580     char                *errmode = "w"; /* Mode to Open Error File  */
1581     int                 cmargc = 0;     /* Piped Command Arg Count  */
1582     char                **cmargv = NULL;/* Piped Command Arg Vector */
1583
1584     /*
1585      * First handle the case where the last thing on the line ends with
1586      * a '&'.  This indicates the desire for the command to be run in a
1587      * subprocess, so we satisfy that desire.
1588      */
1589     ap = argv[argc-1];
1590     if (0 == strcmp("&", ap))
1591         exit(background_process(--argc, argv));
1592     if (*ap && '&' == ap[strlen(ap)-1])
1593         {
1594         ap[strlen(ap)-1] = '\0';
1595         exit(background_process(argc, argv));
1596         }
1597     /*
1598      * Now we handle the general redirection cases that involve '>', '>>',
1599      * '<', and pipes '|'.
1600      */
1601     for (j = 0; j < argc; ++j)
1602         {
1603         if (0 == strcmp("<", argv[j]))
1604             {
1605             if (j+1 >= argc)
1606                 {
1607                 fprintf(stderr,"No input file after < on command line");
1608                 exit(LIB$_WRONUMARG);
1609                 }
1610             in = argv[++j];
1611             continue;
1612             }
1613         if ('<' == *(ap = argv[j]))
1614             {
1615             in = 1 + ap;
1616             continue;
1617             }
1618         if (0 == strcmp(">", ap))
1619             {
1620             if (j+1 >= argc)
1621                 {
1622                 fprintf(stderr,"No output file after > on command line");
1623                 exit(LIB$_WRONUMARG);
1624                 }
1625             out = argv[++j];
1626             continue;
1627             }
1628         if ('>' == *ap)
1629             {
1630             if ('>' == ap[1])
1631                 {
1632                 outmode = "a";
1633                 if ('\0' == ap[2])
1634                     out = argv[++j];
1635                 else
1636                     out = 2 + ap;
1637                 }
1638             else
1639                 out = 1 + ap;
1640             if (j >= argc)
1641                 {
1642                 fprintf(stderr,"No output file after > or >> on command line");
1643                 exit(LIB$_WRONUMARG);
1644                 }
1645             continue;
1646             }
1647         if (('2' == *ap) && ('>' == ap[1]))
1648             {
1649             if ('>' == ap[2])
1650                 {
1651                 errmode = "a";
1652                 if ('\0' == ap[3])
1653                     err = argv[++j];
1654                 else
1655                     err = 3 + ap;
1656                 }
1657             else
1658                 if ('\0' == ap[2])
1659                     err = argv[++j];
1660                 else
1661                     err = 2 + ap;
1662             if (j >= argc)
1663                 {
1664                 fprintf(stderr,"No output file after 2> or 2>> on command line");
1665                 exit(LIB$_WRONUMARG);
1666                 }
1667             continue;
1668             }
1669         if (0 == strcmp("|", argv[j]))
1670             {
1671             if (j+1 >= argc)
1672                 {
1673                 fprintf(stderr,"No command into which to pipe on command line");
1674                 exit(LIB$_WRONUMARG);
1675                 }
1676             cmargc = argc-(j+1);
1677             cmargv = &argv[j+1];
1678             argc = j;
1679             continue;
1680             }
1681         if ('|' == *(ap = argv[j]))
1682             {
1683             ++argv[j];
1684             cmargc = argc-j;
1685             cmargv = &argv[j];
1686             argc = j;
1687             continue;
1688             }
1689         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1690         }
1691     /*
1692      * Allocate and fill in the new argument vector, Some Unix's terminate
1693      * the list with an extra null pointer.
1694      */
1695     New(7002, argv, item_count+1, char *);
1696     *av = argv;
1697     for (j = 0; j < item_count; ++j, list_head = list_head->next)
1698         argv[j] = list_head->value;
1699     *ac = item_count;
1700     if (cmargv != NULL)
1701         {
1702         if (out != NULL)
1703             {
1704             fprintf(stderr,"'|' and '>' may not both be specified on command line");
1705             exit(LIB$_INVARGORD);
1706             }
1707         pipe_and_fork(cmargv);
1708         }
1709
1710     /* Check for input from a pipe (mailbox) */
1711
1712     if (in == NULL && 1 == isapipe(0))
1713         {
1714         char mbxname[L_tmpnam];
1715         long int bufsize;
1716         long int dvi_item = DVI$_DEVBUFSIZ;
1717         $DESCRIPTOR(mbxnam, "");
1718         $DESCRIPTOR(mbxdevnam, "");
1719
1720         /* Input from a pipe, reopen it in binary mode to disable       */
1721         /* carriage control processing.                                 */
1722
1723         fgetname(stdin, mbxname,1);
1724         mbxnam.dsc$a_pointer = mbxname;
1725         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1726         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1727         mbxdevnam.dsc$a_pointer = mbxname;
1728         mbxdevnam.dsc$w_length = sizeof(mbxname);
1729         dvi_item = DVI$_DEVNAM;
1730         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1731         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1732         set_errno(0);
1733         set_vaxc_errno(1);
1734         freopen(mbxname, "rb", stdin);
1735         if (errno != 0)
1736             {
1737             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1738             exit(vaxc$errno);
1739             }
1740         }
1741     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1742         {
1743         fprintf(stderr,"Can't open input file %s as stdin",in);
1744         exit(vaxc$errno);
1745         }
1746     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1747         {
1748         fprintf(stderr,"Can't open output file %s as stdout",out);
1749         exit(vaxc$errno);
1750         }
1751     if (err != NULL) {
1752         FILE *tmperr;
1753         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1754             {
1755             fprintf(stderr,"Can't open error file %s as stderr",err);
1756             exit(vaxc$errno);
1757             }
1758             fclose(tmperr);
1759             if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
1760                 {
1761                 exit(vaxc$errno);
1762                 }
1763         }
1764 #ifdef ARGPROC_DEBUG
1765     fprintf(stderr, "Arglist:\n");
1766     for (j = 0; j < *ac;  ++j)
1767         fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
1768 #endif
1769 }  /* end of getredirection() */
1770 /*}}}*/
1771
1772 static void add_item(struct list_item **head,
1773                      struct list_item **tail,
1774                      char *value,
1775                      int *count)
1776 {
1777     if (*head == 0)
1778         {
1779         New(7003,*head,1,struct list_item);
1780         *tail = *head;
1781         }
1782     else {
1783         New(7004,(*tail)->next,1,struct list_item);
1784         *tail = (*tail)->next;
1785         }
1786     (*tail)->value = value;
1787     ++(*count);
1788 }
1789
1790 static void expand_wild_cards(char *item,
1791                               struct list_item **head,
1792                               struct list_item **tail,
1793                               int *count)
1794 {
1795 int expcount = 0;
1796 unsigned long int context = 0;
1797 int isunix = 0;
1798 char *had_version;
1799 char *had_device;
1800 int had_directory;
1801 char *devdir;
1802 char vmsspec[NAM$C_MAXRSS+1];
1803 $DESCRIPTOR(filespec, "");
1804 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
1805 $DESCRIPTOR(resultspec, "");
1806 unsigned long int zero = 0, sts;
1807
1808     if (strcspn(item, "*%") == strlen(item))
1809         {
1810         add_item(head, tail, item, count);
1811         return;
1812         }
1813     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1814     resultspec.dsc$b_class = DSC$K_CLASS_D;
1815     resultspec.dsc$a_pointer = NULL;
1816     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
1817       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1818     if (!isunix || !filespec.dsc$a_pointer)
1819       filespec.dsc$a_pointer = item;
1820     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1821     /*
1822      * Only return version specs, if the caller specified a version
1823      */
1824     had_version = strchr(item, ';');
1825     /*
1826      * Only return device and directory specs, if the caller specifed either.
1827      */
1828     had_device = strchr(item, ':');
1829     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1830
1831     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
1832                                   &defaultspec, 0, 0, &zero))))
1833         {
1834         char *string;
1835         char *c;
1836
1837         New(7005,string,resultspec.dsc$w_length+1,char);
1838         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1839         string[resultspec.dsc$w_length] = '\0';
1840         if (NULL == had_version)
1841             *((char *)strrchr(string, ';')) = '\0';
1842         if ((!had_directory) && (had_device == NULL))
1843             {
1844             if (NULL == (devdir = strrchr(string, ']')))
1845                 devdir = strrchr(string, '>');
1846             strcpy(string, devdir + 1);
1847             }
1848         /*
1849          * Be consistent with what the C RTL has already done to the rest of
1850          * the argv items and lowercase all of these names.
1851          */
1852         for (c = string; *c; ++c)
1853             if (isupper(*c))
1854                 *c = tolower(*c);
1855         if (isunix) trim_unixpath(string,item);
1856         add_item(head, tail, string, count);
1857         ++expcount;
1858         }
1859     if (sts != RMS$_NMF)
1860         {
1861         set_vaxc_errno(sts);
1862         switch (sts)
1863             {
1864             case RMS$_FNF:
1865             case RMS$_DIR:
1866                 set_errno(ENOENT); break;
1867             case RMS$_DEV:
1868                 set_errno(ENODEV); break;
1869             case RMS$_SYN:
1870                 set_errno(EINVAL); break;
1871             case RMS$_PRV:
1872                 set_errno(EACCES); break;
1873             default:
1874                 _ckvmssts(sts);
1875             }
1876         }
1877     if (expcount == 0)
1878         add_item(head, tail, item, count);
1879     _ckvmssts(lib$sfree1_dd(&resultspec));
1880     _ckvmssts(lib$find_file_end(&context));
1881 }
1882
1883 static int child_st[2];/* Event Flag set when child process completes   */
1884
1885 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
1886
1887 static unsigned long int exit_handler(int *status)
1888 {
1889 short iosb[4];
1890
1891     if (0 == child_st[0])
1892         {
1893 #ifdef ARGPROC_DEBUG
1894         fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
1895 #endif
1896         fflush(stdout);     /* Have to flush pipe for binary data to    */
1897                             /* terminate properly -- <tp@mccall.com>    */
1898         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
1899         sys$dassgn(child_chan);
1900         fclose(stdout);
1901         sys$synch(0, child_st);
1902         }
1903     return(1);
1904 }
1905
1906 static void sig_child(int chan)
1907 {
1908 #ifdef ARGPROC_DEBUG
1909     fprintf(stderr, "Child Completion AST\n");
1910 #endif
1911     if (child_st[0] == 0)
1912         child_st[0] = 1;
1913 }
1914
1915 static struct exit_control_block exit_block =
1916     {
1917     0,
1918     exit_handler,
1919     1,
1920     &exit_block.exit_status,
1921     0
1922     };
1923
1924 static void pipe_and_fork(char **cmargv)
1925 {
1926     char subcmd[2048];
1927     $DESCRIPTOR(cmddsc, "");
1928     static char mbxname[64];
1929     $DESCRIPTOR(mbxdsc, mbxname);
1930     int pid, j;
1931     unsigned long int zero = 0, one = 1;
1932
1933     strcpy(subcmd, cmargv[0]);
1934     for (j = 1; NULL != cmargv[j]; ++j)
1935         {
1936         strcat(subcmd, " \"");
1937         strcat(subcmd, cmargv[j]);
1938         strcat(subcmd, "\"");
1939         }
1940     cmddsc.dsc$a_pointer = subcmd;
1941     cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
1942
1943         create_mbx(&child_chan,&mbxdsc);
1944 #ifdef ARGPROC_DEBUG
1945     fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
1946     fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
1947 #endif
1948     _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
1949                                         0, &pid, child_st, &zero, sig_child,
1950                                         &child_chan));
1951 #ifdef ARGPROC_DEBUG
1952     fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
1953 #endif
1954     sys$dclexh(&exit_block);
1955     if (NULL == freopen(mbxname, "wb", stdout))
1956         {
1957         fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
1958         }
1959 }
1960
1961 static int background_process(int argc, char **argv)
1962 {
1963 char command[2048] = "$";
1964 $DESCRIPTOR(value, "");
1965 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
1966 static $DESCRIPTOR(null, "NLA0:");
1967 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
1968 char pidstring[80];
1969 $DESCRIPTOR(pidstr, "");
1970 int pid;
1971 unsigned long int flags = 17, one = 1, retsts;
1972
1973     strcat(command, argv[0]);
1974     while (--argc)
1975         {
1976         strcat(command, " \"");
1977         strcat(command, *(++argv));
1978         strcat(command, "\"");
1979         }
1980     value.dsc$a_pointer = command;
1981     value.dsc$w_length = strlen(value.dsc$a_pointer);
1982     _ckvmssts(lib$set_symbol(&cmd, &value));
1983     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
1984     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
1985         _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
1986     }
1987     else {
1988         _ckvmssts(retsts);
1989     }
1990 #ifdef ARGPROC_DEBUG
1991     fprintf(stderr, "%s\n", command);
1992 #endif
1993     sprintf(pidstring, "%08X", pid);
1994     fprintf(stderr, "%s\n", pidstring);
1995     pidstr.dsc$a_pointer = pidstring;
1996     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
1997     lib$set_symbol(&pidsymbol, &pidstr);
1998     return(SS$_NORMAL);
1999 }
2000 /*}}}*/
2001 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2002
2003 /* trim_unixpath()
2004  * Trim Unix-style prefix off filespec, so it looks like what a shell
2005  * glob expansion would return (i.e. from specified prefix on, not
2006  * full path).  Note that returned filespec is Unix-style, regardless
2007  * of whether input filespec was VMS-style or Unix-style.
2008  *
2009  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2010  * determine prefix (both may be in VMS or Unix syntax).
2011  *
2012  * Returns !=0 on success, with trimmed filespec replacing contents of
2013  * fspec, and 0 on failure, with contents of fpsec unchanged.
2014  */
2015 /*{{{int trim_unixpath(char *fspec, char *wildspec)*/
2016 int
2017 trim_unixpath(char *fspec, char *wildspec)
2018 {
2019   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2020        *template, *base, *cp1, *cp2;
2021   register int tmplen, reslen = 0;
2022
2023   if (!wildspec || !fspec) return 0;
2024   if (strpbrk(wildspec,"]>:") != NULL) {
2025     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2026     else template = unixified;
2027   }
2028   else template = wildspec;
2029   if (strpbrk(fspec,"]>:") != NULL) {
2030     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2031     else base = unixified;
2032     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2033      * check to see that final result fits into (isn't longer than) fspec */
2034     reslen = strlen(fspec);
2035   }
2036   else base = fspec;
2037
2038   /* No prefix or absolute path on wildcard, so nothing to remove */
2039   if (!*template || *template == '/') {
2040     if (base == fspec) return 1;
2041     tmplen = strlen(unixified);
2042     if (tmplen > reslen) return 0;  /* not enough space */
2043     /* Copy unixified resultant, including trailing NUL */
2044     memmove(fspec,unixified,tmplen+1);
2045     return 1;
2046   }
2047
2048   /* Find prefix to template consisting of path elements without wildcards */
2049   if ((cp1 = strpbrk(template,"*%?")) == NULL)
2050     for (cp1 = template; *cp1; cp1++) ;
2051   else while (cp1 > template && *cp1 != '/') cp1--;
2052   for (cp2 = base; *cp2; cp2++) ;  /* Find end of resultant filespec */
2053
2054   /* Wildcard was in first element, so we don't have a reliable string to
2055    * match against.  Guess where to trim resultant filespec by counting
2056    * directory levels in the Unix template.  (We could do this instead of
2057    * string matching in all cases, since Unix doesn't have a ... wildcard
2058    * that can expand into multiple levels of subdirectory, but we try for
2059    * the string match so our caller can interpret foo/.../bar.* as
2060    * [.foo...]bar.* if it wants, and only get burned if there was a
2061    * wildcard in the first word (in which case, caveat caller). */
2062   if (cp1 == template) {
2063     int subdirs = 0;
2064     for ( ; *cp1; cp1++) if (*cp1 == '/') subdirs++;
2065     /* need to back one more '/' than in template, to pick up leading dirname */
2066     subdirs++;
2067     while (cp2 > base) {
2068       if (*cp2 == '/') subdirs--;
2069       if (!subdirs) break;  /* quit without decrement when we hit last '/' */
2070       cp2--;
2071     }
2072     /* ran out of directories on resultant; allow for already trimmed
2073      * resultant, which hits start of string looking for leading '/' */
2074     if (subdirs && (cp2 != base || subdirs != 1)) return 0;
2075     /* Move past leading '/', if there is one */
2076     base = cp2 + (*cp2 == '/' ? 1 : 0);
2077     tmplen = strlen(base);
2078     if (reslen && tmplen > reslen) return 0;  /* not enough space */
2079     memmove(fspec,base,tmplen+1);  /* copy result to fspec, with trailing NUL */
2080     return 1;
2081   }
2082   /* We have a prefix string of complete directory names, so we
2083    * try to find it on the resultant filespec */
2084   else {
2085     tmplen = cp1 - template;
2086     if (!memcmp(base,template,tmplen)) { /* Nothing before prefix; we're done */
2087       if (reslen) { /* we converted to Unix syntax; copy result over */
2088         tmplen = cp2 - base;
2089         if (tmplen > reslen) return 0;  /* not enough space */
2090         memmove(fspec,base,tmplen+1);  /* Copy trimmed spec + trailing NUL */
2091       }
2092       return 1;
2093     }
2094     for ( ; cp2 - base > tmplen; base++) {
2095        if (*base != '/') continue;
2096        if (!memcmp(base + 1,template,tmplen)) break;
2097     }
2098
2099     if (cp2 - base == tmplen) return 0;  /* Not there - not good */
2100     base++;  /* Move past leading '/' */
2101     if (reslen && cp2 - base > reslen) return 0;  /* not enough space */
2102     /* Copy down remaining portion of filespec, including trailing NUL */
2103     memmove(fspec,base,cp2 - base + 1);
2104     return 1;
2105   }
2106
2107 }  /* end of trim_unixpath() */
2108 /*}}}*/
2109
2110
2111 /*
2112  *  VMS readdir() routines.
2113  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2114  *  This code has no copyright.
2115  *
2116  *  21-Jul-1994  Charles Bailey  bailey@genetics.upenn.edu
2117  *  Minor modifications to original routines.
2118  */
2119
2120     /* Number of elements in vms_versions array */
2121 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
2122
2123 /*
2124  *  Open a directory, return a handle for later use.
2125  */
2126 /*{{{ DIR *opendir(char*name) */
2127 DIR *
2128 opendir(char *name)
2129 {
2130     DIR *dd;
2131     char dir[NAM$C_MAXRSS+1];
2132
2133     /* Get memory for the handle, and the pattern. */
2134     New(7006,dd,1,DIR);
2135     if (do_tovmspath(name,dir,0) == NULL) {
2136       Safefree((char *)dd);
2137       return(NULL);
2138     }
2139     New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2140
2141     /* Fill in the fields; mainly playing with the descriptor. */
2142     (void)sprintf(dd->pattern, "%s*.*",dir);
2143     dd->context = 0;
2144     dd->count = 0;
2145     dd->vms_wantversions = 0;
2146     dd->pat.dsc$a_pointer = dd->pattern;
2147     dd->pat.dsc$w_length = strlen(dd->pattern);
2148     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2149     dd->pat.dsc$b_class = DSC$K_CLASS_S;
2150
2151     return dd;
2152 }  /* end of opendir() */
2153 /*}}}*/
2154
2155 /*
2156  *  Set the flag to indicate we want versions or not.
2157  */
2158 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2159 void
2160 vmsreaddirversions(DIR *dd, int flag)
2161 {
2162     dd->vms_wantversions = flag;
2163 }
2164 /*}}}*/
2165
2166 /*
2167  *  Free up an opened directory.
2168  */
2169 /*{{{ void closedir(DIR *dd)*/
2170 void
2171 closedir(DIR *dd)
2172 {
2173     (void)lib$find_file_end(&dd->context);
2174     Safefree(dd->pattern);
2175     Safefree((char *)dd);
2176 }
2177 /*}}}*/
2178
2179 /*
2180  *  Collect all the version numbers for the current file.
2181  */
2182 static void
2183 collectversions(dd)
2184     DIR *dd;
2185 {
2186     struct dsc$descriptor_s     pat;
2187     struct dsc$descriptor_s     res;
2188     struct dirent *e;
2189     char *p, *text, buff[sizeof dd->entry.d_name];
2190     int i;
2191     unsigned long context, tmpsts;
2192
2193     /* Convenient shorthand. */
2194     e = &dd->entry;
2195
2196     /* Add the version wildcard, ignoring the "*.*" put on before */
2197     i = strlen(dd->pattern);
2198     New(7008,text,i + e->d_namlen + 3,char);
2199     (void)strcpy(text, dd->pattern);
2200     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2201
2202     /* Set up the pattern descriptor. */
2203     pat.dsc$a_pointer = text;
2204     pat.dsc$w_length = i + e->d_namlen - 1;
2205     pat.dsc$b_dtype = DSC$K_DTYPE_T;
2206     pat.dsc$b_class = DSC$K_CLASS_S;
2207
2208     /* Set up result descriptor. */
2209     res.dsc$a_pointer = buff;
2210     res.dsc$w_length = sizeof buff - 2;
2211     res.dsc$b_dtype = DSC$K_DTYPE_T;
2212     res.dsc$b_class = DSC$K_CLASS_S;
2213
2214     /* Read files, collecting versions. */
2215     for (context = 0, e->vms_verscount = 0;
2216          e->vms_verscount < VERSIZE(e);
2217          e->vms_verscount++) {
2218         tmpsts = lib$find_file(&pat, &res, &context);
2219         if (tmpsts == RMS$_NMF || context == 0) break;
2220         _ckvmssts(tmpsts);
2221         buff[sizeof buff - 1] = '\0';
2222         if ((p = strchr(buff, ';')))
2223             e->vms_versions[e->vms_verscount] = atoi(p + 1);
2224         else
2225             e->vms_versions[e->vms_verscount] = -1;
2226     }
2227
2228     _ckvmssts(lib$find_file_end(&context));
2229     Safefree(text);
2230
2231 }  /* end of collectversions() */
2232
2233 /*
2234  *  Read the next entry from the directory.
2235  */
2236 /*{{{ struct dirent *readdir(DIR *dd)*/
2237 struct dirent *
2238 readdir(DIR *dd)
2239 {
2240     struct dsc$descriptor_s     res;
2241     char *p, buff[sizeof dd->entry.d_name];
2242     unsigned long int tmpsts;
2243
2244     /* Set up result descriptor, and get next file. */
2245     res.dsc$a_pointer = buff;
2246     res.dsc$w_length = sizeof buff - 2;
2247     res.dsc$b_dtype = DSC$K_DTYPE_T;
2248     res.dsc$b_class = DSC$K_CLASS_S;
2249     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2250     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
2251     if (!(tmpsts & 1)) {
2252       set_vaxc_errno(tmpsts);
2253       switch (tmpsts) {
2254         case RMS$_PRV:
2255           set_errno(EACCES); break;
2256         case RMS$_DEV:
2257           set_errno(ENODEV); break;
2258         case RMS$_DIR:
2259         case RMS$_FNF:
2260           set_errno(ENOENT); break;
2261         default:
2262           set_errno(EVMSERR);
2263       }
2264       return NULL;
2265     }
2266     dd->count++;
2267     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2268     buff[sizeof buff - 1] = '\0';
2269     for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2270     *p = '\0';
2271
2272     /* Skip any directory component and just copy the name. */
2273     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2274     else (void)strcpy(dd->entry.d_name, buff);
2275
2276     /* Clobber the version. */
2277     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2278
2279     dd->entry.d_namlen = strlen(dd->entry.d_name);
2280     dd->entry.vms_verscount = 0;
2281     if (dd->vms_wantversions) collectversions(dd);
2282     return &dd->entry;
2283
2284 }  /* end of readdir() */
2285 /*}}}*/
2286
2287 /*
2288  *  Return something that can be used in a seekdir later.
2289  */
2290 /*{{{ long telldir(DIR *dd)*/
2291 long
2292 telldir(DIR *dd)
2293 {
2294     return dd->count;
2295 }
2296 /*}}}*/
2297
2298 /*
2299  *  Return to a spot where we used to be.  Brute force.
2300  */
2301 /*{{{ void seekdir(DIR *dd,long count)*/
2302 void
2303 seekdir(DIR *dd, long count)
2304 {
2305     int vms_wantversions;
2306
2307     /* If we haven't done anything yet... */
2308     if (dd->count == 0)
2309         return;
2310
2311     /* Remember some state, and clear it. */
2312     vms_wantversions = dd->vms_wantversions;
2313     dd->vms_wantversions = 0;
2314     _ckvmssts(lib$find_file_end(&dd->context));
2315     dd->context = 0;
2316
2317     /* The increment is in readdir(). */
2318     for (dd->count = 0; dd->count < count; )
2319         (void)readdir(dd);
2320
2321     dd->vms_wantversions = vms_wantversions;
2322
2323 }  /* end of seekdir() */
2324 /*}}}*/
2325
2326 /* VMS subprocess management
2327  *
2328  * my_vfork() - just a vfork(), after setting a flag to record that
2329  * the current script is trying a Unix-style fork/exec.
2330  *
2331  * vms_do_aexec() and vms_do_exec() are called in response to the
2332  * perl 'exec' function.  If this follows a vfork call, then they
2333  * call out the the regular perl routines in doio.c which do an
2334  * execvp (for those who really want to try this under VMS).
2335  * Otherwise, they do exactly what the perl docs say exec should
2336  * do - terminate the current script and invoke a new command
2337  * (See below for notes on command syntax.)
2338  *
2339  * do_aspawn() and do_spawn() implement the VMS side of the perl
2340  * 'system' function.
2341  *
2342  * Note on command arguments to perl 'exec' and 'system': When handled
2343  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2344  * are concatenated to form a DCL command string.  If the first arg
2345  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2346  * the the command string is hrnded off to DCL directly.  Otherwise,
2347  * the first token of the command is taken as the filespec of an image
2348  * to run.  The filespec is expanded using a default type of '.EXE' and
2349  * the process defaults for device, directory, etc., and the resultant
2350  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2351  * the command string as parameters.  This is perhaps a bit compicated,
2352  * but I hope it will form a happy medium between what VMS folks expect
2353  * from lib$spawn and what Unix folks expect from exec.
2354  */
2355
2356 static int vfork_called;
2357
2358 /*{{{int my_vfork()*/
2359 int
2360 my_vfork()
2361 {
2362   vfork_called++;
2363   return vfork();
2364 }
2365 /*}}}*/
2366
2367
2368 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2369
2370 static void
2371 vms_execfree() {
2372   if (Cmd) {
2373     Safefree(Cmd);
2374     Cmd = Nullch;
2375   }
2376   if (VMScmd.dsc$a_pointer) {
2377     Safefree(VMScmd.dsc$a_pointer);
2378     VMScmd.dsc$w_length = 0;
2379     VMScmd.dsc$a_pointer = Nullch;
2380   }
2381 }
2382
2383 static char *
2384 setup_argstr(SV *really, SV **mark, SV **sp)
2385 {
2386   char *junk, *tmps = Nullch;
2387   register size_t cmdlen = 0;
2388   size_t rlen;
2389   register SV **idx;
2390
2391   idx = mark;
2392   if (really) {
2393     tmps = SvPV(really,rlen);
2394     if (*tmps) {
2395       cmdlen += rlen + 1;
2396       idx++;
2397     }
2398   }
2399
2400   for (idx++; idx <= sp; idx++) {
2401     if (*idx) {
2402       junk = SvPVx(*idx,rlen);
2403       cmdlen += rlen ? rlen + 1 : 0;
2404     }
2405   }
2406   New(401,Cmd,cmdlen+1,char);
2407
2408   if (tmps && *tmps) {
2409     strcpy(Cmd,tmps);
2410     mark++;
2411   }
2412   else *Cmd = '\0';
2413   while (++mark <= sp) {
2414     if (*mark) {
2415       strcat(Cmd," ");
2416       strcat(Cmd,SvPVx(*mark,na));
2417     }
2418   }
2419   return Cmd;
2420
2421 }  /* end of setup_argstr() */
2422
2423
2424 static unsigned long int
2425 setup_cmddsc(char *cmd, int check_img)
2426 {
2427   char resspec[NAM$C_MAXRSS+1];
2428   $DESCRIPTOR(defdsc,".EXE");
2429   $DESCRIPTOR(resdsc,resspec);
2430   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2431   unsigned long int cxt = 0, flags = 1, retsts;
2432   register char *s, *rest, *cp;
2433   register int isdcl = 0;
2434
2435   s = cmd;
2436   while (*s && isspace(*s)) s++;
2437   if (check_img) {
2438     if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2439       isdcl = 1;     /* no dev/dir separators (i.e. not a foreign command) */
2440       for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2441         if (*cp == ':' || *cp == '[' || *cp == '<') {
2442           isdcl = 0;
2443           break;
2444         }
2445       }
2446     }
2447   }
2448   else isdcl = 1;
2449   if (isdcl) {  /* It's a DCL command, just do it. */
2450     VMScmd.dsc$w_length = strlen(cmd);
2451     if (cmd == Cmd) {
2452        VMScmd.dsc$a_pointer = Cmd;
2453        Cmd = Nullch;  /* Don't try to free twice in vms_execfree() */
2454     }
2455     else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2456   }
2457   else {                           /* assume first token is an image spec */
2458     cmd = s;
2459     while (*s && !isspace(*s)) s++;
2460     rest = *s ? s : 0;
2461     imgdsc.dsc$a_pointer = cmd;
2462     imgdsc.dsc$w_length = s - cmd;
2463     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2464     if (!(retsts & 1)) {
2465       /* just hand off status values likely to be due to user error */
2466       if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2467           retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2468          (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2469       else { _ckvmssts(retsts); }
2470     }
2471     else {
2472       _ckvmssts(lib$find_file_end(&cxt));
2473       s = resspec;
2474       while (*s && !isspace(*s)) s++;
2475       *s = '\0';
2476       New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2477       strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2478       strcat(VMScmd.dsc$a_pointer,resspec);
2479       if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2480       VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2481     }
2482   }
2483
2484   return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2485
2486 }  /* end of setup_cmddsc() */
2487
2488
2489 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2490 bool
2491 vms_do_aexec(SV *really,SV **mark,SV **sp)
2492 {
2493   if (sp > mark) {
2494     if (vfork_called) {           /* this follows a vfork - act Unixish */
2495       vfork_called--;
2496       if (vfork_called < 0) {
2497         warn("Internal inconsistency in tracking vforks");
2498         vfork_called = 0;
2499       }
2500       else return do_aexec(really,mark,sp);
2501     }
2502                                            /* no vfork - act VMSish */
2503     return vms_do_exec(setup_argstr(really,mark,sp));
2504
2505   }
2506
2507   return FALSE;
2508 }  /* end of vms_do_aexec() */
2509 /*}}}*/
2510
2511 /* {{{bool vms_do_exec(char *cmd) */
2512 bool
2513 vms_do_exec(char *cmd)
2514 {
2515
2516   if (vfork_called) {             /* this follows a vfork - act Unixish */
2517     vfork_called--;
2518     if (vfork_called < 0) {
2519       warn("Internal inconsistency in tracking vforks");
2520       vfork_called = 0;
2521     }
2522     else return do_exec(cmd);
2523   }
2524
2525   {                               /* no vfork - act VMSish */
2526     unsigned long int retsts;
2527
2528     if ((retsts = setup_cmddsc(cmd,1)) & 1)
2529       retsts = lib$do_command(&VMScmd);
2530
2531     set_errno(EVMSERR);
2532     set_vaxc_errno(retsts);
2533     if (dowarn)
2534       warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2535     vms_execfree();
2536   }
2537
2538   return FALSE;
2539
2540 }  /* end of vms_do_exec() */
2541 /*}}}*/
2542
2543 unsigned long int do_spawn(char *);
2544
2545 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2546 unsigned long int
2547 do_aspawn(SV *really,SV **mark,SV **sp)
2548 {
2549   if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2550
2551   return SS$_ABORT;
2552 }  /* end of do_aspawn() */
2553 /*}}}*/
2554
2555 /* {{{unsigned long int do_spawn(char *cmd) */
2556 unsigned long int
2557 do_spawn(char *cmd)
2558 {
2559   unsigned long int substs, hadcmd = 1;
2560
2561   if (!cmd || !*cmd) {
2562     hadcmd = 0;
2563     _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2564   }
2565   else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2566     _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2567   }
2568
2569   if (!(substs&1)) {
2570     set_errno(EVMSERR);
2571     set_vaxc_errno(substs);
2572     if (dowarn)
2573       warn("Can't spawn \"%s\": %s",
2574            hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2575   }
2576   vms_execfree();
2577   return substs;
2578
2579 }  /* end of do_spawn() */
2580 /*}}}*/
2581
2582 /*
2583  * A simple fwrite replacement which outputs itmsz*nitm chars without
2584  * introducing record boundaries every itmsz chars.
2585  */
2586 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2587 int
2588 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2589 {
2590   register char *cp, *end;
2591
2592   end = (char *)src + itmsz * nitm;
2593
2594   while ((char *)src <= end) {
2595     for (cp = src; cp <= end; cp++) if (!*cp) break;
2596     if (fputs(src,dest) == EOF) return EOF;
2597     if (cp < end)
2598       if (fputc('\0',dest) == EOF) return EOF;
2599     src = cp + 1;
2600   }
2601
2602   return 1;
2603
2604 }  /* end of my_fwrite() */
2605 /*}}}*/
2606
2607 /*
2608  * Here are replacements for the following Unix routines in the VMS environment:
2609  *      getpwuid    Get information for a particular UIC or UID
2610  *      getpwnam    Get information for a named user
2611  *      getpwent    Get information for each user in the rights database
2612  *      setpwent    Reset search to the start of the rights database
2613  *      endpwent    Finish searching for users in the rights database
2614  *
2615  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2616  * (defined in pwd.h), which contains the following fields:-
2617  *      struct passwd {
2618  *              char        *pw_name;    Username (in lower case)
2619  *              char        *pw_passwd;  Hashed password
2620  *              unsigned int pw_uid;     UIC
2621  *              unsigned int pw_gid;     UIC group  number
2622  *              char        *pw_unixdir; Default device/directory (VMS-style)
2623  *              char        *pw_gecos;   Owner name
2624  *              char        *pw_dir;     Default device/directory (Unix-style)
2625  *              char        *pw_shell;   Default CLI name (eg. DCL)
2626  *      };
2627  * If the specified user does not exist, getpwuid and getpwnam return NULL.
2628  *
2629  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2630  * not the UIC member number (eg. what's returned by getuid()),
2631  * getpwuid() can accept either as input (if uid is specified, the caller's
2632  * UIC group is used), though it won't recognise gid=0.
2633  *
2634  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2635  * information about other users in your group or in other groups, respectively.
2636  * If the required privilege is not available, then these routines fill only
2637  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2638  * string).
2639  *
2640  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2641  */
2642
2643 /* sizes of various UAF record fields */
2644 #define UAI$S_USERNAME 12
2645 #define UAI$S_IDENT    31
2646 #define UAI$S_OWNER    31
2647 #define UAI$S_DEFDEV   31
2648 #define UAI$S_DEFDIR   63
2649 #define UAI$S_DEFCLI   31
2650 #define UAI$S_PWD       8
2651
2652 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
2653                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2654                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
2655
2656 static char __empty[]= "";
2657 static struct passwd __passwd_empty=
2658     {(char *) __empty, (char *) __empty, 0, 0,
2659      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2660 static int contxt= 0;
2661 static struct passwd __pwdcache;
2662 static char __pw_namecache[UAI$S_IDENT+1];
2663
2664 /*
2665  * This routine does most of the work extracting the user information.
2666  */
2667 static int fillpasswd (const char *name, struct passwd *pwd)
2668 {
2669     static struct {
2670         unsigned char length;
2671         char pw_gecos[UAI$S_OWNER+1];
2672     } owner;
2673     static union uicdef uic;
2674     static struct {
2675         unsigned char length;
2676         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2677     } defdev;
2678     static struct {
2679         unsigned char length;
2680         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2681     } defdir;
2682     static struct {
2683         unsigned char length;
2684         char pw_shell[UAI$S_DEFCLI+1];
2685     } defcli;
2686     static char pw_passwd[UAI$S_PWD+1];
2687
2688     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2689     struct dsc$descriptor_s name_desc;
2690     unsigned long int sts;
2691
2692     static struct itmlst_3 itmlst[]= {
2693         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
2694         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
2695         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
2696         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
2697         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
2698         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
2699         {0,                0,           NULL,    NULL}};
2700
2701     name_desc.dsc$w_length=  strlen(name);
2702     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
2703     name_desc.dsc$b_class=   DSC$K_CLASS_S;
2704     name_desc.dsc$a_pointer= (char *) name;
2705
2706 /*  Note that sys$getuai returns many fields as counted strings. */
2707     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2708     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2709       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2710     }
2711     else { _ckvmssts(sts); }
2712     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
2713
2714     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
2715     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2716     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2717     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2718     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2719     owner.pw_gecos[lowner]=            '\0';
2720     defdev.pw_dir[ldefdev+ldefdir]= '\0';
2721     defcli.pw_shell[ldefcli]=          '\0';
2722     if (valid_uic(uic)) {
2723         pwd->pw_uid= uic.uic$l_uic;
2724         pwd->pw_gid= uic.uic$v_group;
2725     }
2726     else
2727       warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2728     pwd->pw_passwd=  pw_passwd;
2729     pwd->pw_gecos=   owner.pw_gecos;
2730     pwd->pw_dir=     defdev.pw_dir;
2731     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2732     pwd->pw_shell=   defcli.pw_shell;
2733     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2734         int ldir;
2735         ldir= strlen(pwd->pw_unixdir) - 1;
2736         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2737     }
2738     else
2739         strcpy(pwd->pw_unixdir, pwd->pw_dir);
2740     __mystrtolower(pwd->pw_unixdir);
2741     return 1;
2742 }
2743
2744 /*
2745  * Get information for a named user.
2746 */
2747 /*{{{struct passwd *getpwnam(char *name)*/
2748 struct passwd *my_getpwnam(char *name)
2749 {
2750     struct dsc$descriptor_s name_desc;
2751     union uicdef uic;
2752     unsigned long int status, stat;
2753
2754     __pwdcache = __passwd_empty;
2755     if (!fillpasswd(name, &__pwdcache)) {
2756       /* We still may be able to determine pw_uid and pw_gid */
2757       name_desc.dsc$w_length=  strlen(name);
2758       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
2759       name_desc.dsc$b_class=   DSC$K_CLASS_S;
2760       name_desc.dsc$a_pointer= (char *) name;
2761       if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2762         __pwdcache.pw_uid= uic.uic$l_uic;
2763         __pwdcache.pw_gid= uic.uic$v_group;
2764       }
2765       else {
2766         if (stat == SS$_NOSUCHID || stat == SS$_IVIDENT || stat == RMS$_PRV) {
2767           set_vaxc_errno(stat);
2768           set_errno(stat == RMS$_PRV ? EACCES : EINVAL);
2769           return NULL;
2770         }
2771         else { _ckvmssts(stat); }
2772       }
2773     }
2774     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
2775     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
2776     __pwdcache.pw_name= __pw_namecache;
2777     return &__pwdcache;
2778 }  /* end of my_getpwnam() */
2779 /*}}}*/
2780
2781 /*
2782  * Get information for a particular UIC or UID.
2783  * Called by my_getpwent with uid=-1 to list all users.
2784 */
2785 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
2786 struct passwd *my_getpwuid(Uid_t uid)
2787 {
2788     const $DESCRIPTOR(name_desc,__pw_namecache);
2789     unsigned short lname;
2790     union uicdef uic;
2791     unsigned long int status;
2792
2793     if (uid == (unsigned int) -1) {
2794       do {
2795         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
2796         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
2797           set_vaxc_errno(status);
2798           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2799           my_endpwent();
2800           return NULL;
2801         }
2802         else { _ckvmssts(status); }
2803       } while (!valid_uic (uic));
2804     }
2805     else {
2806       uic.uic$l_uic= uid;
2807       if (!uic.uic$v_group)
2808         uic.uic$v_group= getgid();
2809       if (valid_uic(uic))
2810         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
2811       else status = SS$_IVIDENT;
2812       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
2813           status == RMS$_PRV) {
2814         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2815         return NULL;
2816       }
2817       else { _ckvmssts(status); }
2818     }
2819     __pw_namecache[lname]= '\0';
2820     __mystrtolower(__pw_namecache);
2821
2822     __pwdcache = __passwd_empty;
2823     __pwdcache.pw_name = __pw_namecache;
2824
2825 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
2826     The identifier's value is usually the UIC, but it doesn't have to be,
2827     so if we can, we let fillpasswd update this. */
2828     __pwdcache.pw_uid =  uic.uic$l_uic;
2829     __pwdcache.pw_gid =  uic.uic$v_group;
2830
2831     fillpasswd(__pw_namecache, &__pwdcache);
2832     return &__pwdcache;
2833
2834 }  /* end of my_getpwuid() */
2835 /*}}}*/
2836
2837 /*
2838  * Get information for next user.
2839 */
2840 /*{{{struct passwd *my_getpwent()*/
2841 struct passwd *my_getpwent()
2842 {
2843     return (my_getpwuid((unsigned int) -1));
2844 }
2845 /*}}}*/
2846
2847 /*
2848  * Finish searching rights database for users.
2849 */
2850 /*{{{void my_endpwent()*/
2851 void my_endpwent()
2852 {
2853     if (contxt) {
2854       _ckvmssts(sys$finish_rdb(&contxt));
2855       contxt= 0;
2856     }
2857 }
2858 /*}}}*/
2859
2860
2861 /* my_gmtime
2862  * If the CRTL has a real gmtime(), use it, else look for the logical
2863  * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
2864  * VMS >= 6.0.  Can be manually defined under earlier versions of VMS
2865  * to translate to the number of seconds which must be added to UTC
2866  * to get to the local time of the system.
2867  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
2868  */
2869
2870 /*{{{struct tm *my_gmtime(const time_t *time)*/
2871 /* We #defined 'gmtime' as 'my_gmtime' in vmsish.h.  #undef it here
2872  * so we can call the CRTL's routine to see if it works.
2873  */
2874 #undef gmtime
2875 struct tm *
2876 my_gmtime(const time_t *time)
2877 {
2878   static int gmtime_emulation_type;
2879   static time_t utc_offset_secs;
2880   char *p;
2881   time_t when;
2882
2883   if (gmtime_emulation_type == 0) {
2884     gmtime_emulation_type++;
2885     when = 300000000;
2886     if (gmtime(&when) == NULL) {  /* CRTL gmtime() is just a stub */
2887       gmtime_emulation_type++;
2888       if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
2889         gmtime_emulation_type++;
2890       else
2891         utc_offset_secs = (time_t) atol(p);
2892     }
2893   }
2894
2895   switch (gmtime_emulation_type) {
2896     case 1:
2897       return gmtime(time);
2898     case 2:
2899       when = *time - utc_offset_secs;
2900       return localtime(&when);
2901     default:
2902       warn("gmtime not supported on this system");
2903       return NULL;
2904   }
2905 }  /* end of my_gmtime() */
2906 /* Reset definition for later calls */
2907 #define gmtime(t) my_gmtime(t)
2908 /*}}}*/
2909
2910
2911 /*
2912  * flex_stat, flex_fstat
2913  * basic stat, but gets it right when asked to stat
2914  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
2915  */
2916
2917 /* encode_dev packs a VMS device name string into an integer to allow
2918  * simple comparisons. This can be used, for example, to check whether two
2919  * files are located on the same device, by comparing their encoded device
2920  * names. Even a string comparison would not do, because stat() reuses the
2921  * device name buffer for each call; so without encode_dev, it would be
2922  * necessary to save the buffer and use strcmp (this would mean a number of
2923  * changes to the standard Perl code, to say nothing of what a Perl script
2924  * would have to do.
2925  *
2926  * The device lock id, if it exists, should be unique (unless perhaps compared
2927  * with lock ids transferred from other nodes). We have a lock id if the disk is
2928  * mounted cluster-wide, which is when we tend to get long (host-qualified)
2929  * device names. Thus we use the lock id in preference, and only if that isn't
2930  * available, do we try to pack the device name into an integer (flagged by
2931  * the sign bit (LOCKID_MASK) being set).
2932  *
2933  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
2934  * name and its encoded form, but it seems very unlikely that we will find
2935  * two files on different disks that share the same encoded device names,
2936  * and even more remote that they will share the same file id (if the test
2937  * is to check for the same file).
2938  *
2939  * A better method might be to use sys$device_scan on the first call, and to
2940  * search for the device, returning an index into the cached array.
2941  * The number returned would be more intelligable.
2942  * This is probably not worth it, and anyway would take quite a bit longer
2943  * on the first call.
2944  */
2945 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
2946 static dev_t encode_dev (const char *dev)
2947 {
2948   int i;
2949   unsigned long int f;
2950   dev_t enc;
2951   char c;
2952   const char *q;
2953
2954   if (!dev || !dev[0]) return 0;
2955
2956 #if LOCKID_MASK
2957   {
2958     struct dsc$descriptor_s dev_desc;
2959     unsigned long int status, lockid, item = DVI$_LOCKID;
2960
2961     /* For cluster-mounted disks, the disk lock identifier is unique, so we
2962        can try that first. */
2963     dev_desc.dsc$w_length =  strlen (dev);
2964     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
2965     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
2966     dev_desc.dsc$a_pointer = (char *) dev;
2967     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
2968     if (lockid) return (lockid & ~LOCKID_MASK);
2969   }
2970 #endif
2971
2972   /* Otherwise we try to encode the device name */
2973   enc = 0;
2974   f = 1;
2975   i = 0;
2976   for (q = dev + strlen(dev); q--; q >= dev) {
2977     if (isdigit (*q))
2978       c= (*q) - '0';
2979     else if (isalpha (toupper (*q)))
2980       c= toupper (*q) - 'A' + (char)10;
2981     else
2982       continue; /* Skip '$'s */
2983     i++;
2984     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
2985     if (i>1) f *= 36;
2986     enc += f * (unsigned long int) c;
2987   }
2988   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
2989
2990 }  /* end of encode_dev() */
2991
2992 static char namecache[NAM$C_MAXRSS+1];
2993
2994 static int
2995 is_null_device(name)
2996     const char *name;
2997 {
2998     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
2999        The underscore prefix, controller letter, and unit number are
3000        independently optional; for our purposes, the colon punctuation
3001        is not.  The colon can be trailed by optional directory and/or
3002        filename, but two consecutive colons indicates a nodename rather
3003        than a device.  [pr]  */
3004   if (*name == '_') ++name;
3005   if (tolower(*name++) != 'n') return 0;
3006   if (tolower(*name++) != 'l') return 0;
3007   if (tolower(*name) == 'a') ++name;
3008   if (*name == '0') ++name;
3009   return (*name++ == ':') && (*name != ':');
3010 }
3011
3012 /* Do the permissions allow some operation?  Assumes statcache already set. */
3013 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3014  * subset of the applicable information.
3015  */
3016 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3017 I32
3018 cando(I32 bit, I32 effective, struct stat *statbufp)
3019 {
3020   if (statbufp == &statcache)
3021     return cando_by_name(bit,effective,namecache);
3022   else {
3023     char fname[NAM$C_MAXRSS+1];
3024     unsigned long int retsts;
3025     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3026                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3027
3028     /* If the struct mystat is stale, we're OOL; stat() overwrites the
3029        device name on successive calls */
3030     devdsc.dsc$a_pointer = statbufp->st_devnam;
3031     devdsc.dsc$w_length = strlen(statbufp->st_devnam);
3032     namdsc.dsc$a_pointer = fname;
3033     namdsc.dsc$w_length = sizeof fname - 1;
3034
3035     retsts = lib$fid_to_name(&devdsc,&(statbufp->st_ino),&namdsc,
3036                              &namdsc.dsc$w_length,0,0);
3037     if (retsts & 1) {
3038       fname[namdsc.dsc$w_length] = '\0';
3039       return cando_by_name(bit,effective,fname);
3040     }
3041     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3042       warn("Can't get filespec - stale stat buffer?\n");
3043       return FALSE;
3044     }
3045     _ckvmssts(retsts);
3046     return FALSE;  /* Should never get to here */
3047   }
3048 }  /* end of cando() */
3049 /*}}}*/
3050
3051
3052 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3053 I32
3054 cando_by_name(I32 bit, I32 effective, char *fname)
3055 {
3056   static char usrname[L_cuserid];
3057   static struct dsc$descriptor_s usrdsc =
3058          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3059   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3060   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3061   unsigned short int retlen;
3062   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3063   union prvdef curprv;
3064   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3065          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3066   struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3067          {0,0,0,0}};
3068
3069   if (!fname || !*fname) return FALSE;
3070   /* Make sure we expand logical names, since sys$check_access doesn't */
3071   if (!strpbrk(fname,"/]>:")) {
3072     strcpy(fileified,fname);
3073     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3074     fname = fileified;
3075   }
3076   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3077   retlen = namdsc.dsc$w_length = strlen(vmsname);
3078   namdsc.dsc$a_pointer = vmsname;
3079   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3080       vmsname[retlen-1] == ':') {
3081     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3082     namdsc.dsc$w_length = strlen(fileified);
3083     namdsc.dsc$a_pointer = fileified;
3084   }
3085
3086   if (!usrdsc.dsc$w_length) {
3087     cuserid(usrname);
3088     usrdsc.dsc$w_length = strlen(usrname);
3089   }
3090
3091   switch (bit) {
3092     case S_IXUSR:
3093     case S_IXGRP:
3094     case S_IXOTH:
3095       access = ARM$M_EXECUTE;
3096       break;
3097     case S_IRUSR:
3098     case S_IRGRP:
3099     case S_IROTH:
3100       access = ARM$M_READ;
3101       break;
3102     case S_IWUSR:
3103     case S_IWGRP:
3104     case S_IWOTH:
3105       access = ARM$M_WRITE;
3106       break;
3107     case S_IDUSR:
3108     case S_IDGRP:
3109     case S_IDOTH:
3110       access = ARM$M_DELETE;
3111       break;
3112     default:
3113       return FALSE;
3114   }
3115
3116   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3117 #ifndef SS$_NOSUCHOBJECT  /* Older versions of ssdef.h don't have this */
3118 #  define SS$_NOSUCHOBJECT 2696
3119 #endif
3120   if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3121       retsts == RMS$_FNF   || retsts == RMS$_DIR         ||
3122       retsts == RMS$_DEV) {
3123     set_errno(retsts == SS$_NOPRIV ? EACCES : ENOENT); set_vaxc_errno(retsts);
3124     return FALSE;
3125   }
3126   if (retsts == SS$_NORMAL) {
3127     if (!privused) return TRUE;
3128     /* We can get access, but only by using privs.  Do we have the
3129        necessary privs currently enabled? */
3130     _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3131     if ((privused & CHP$M_BYPASS) &&  !curprv.prv$v_bypass)  return FALSE;
3132     if ((privused & CHP$M_SYSPRV) &&  !curprv.prv$v_sysprv &&
3133                                       !curprv.prv$v_bypass)  return FALSE;
3134     if ((privused & CHP$M_GRPPRV) &&  !curprv.prv$v_grpprv &&
3135          !curprv.prv$v_sysprv &&      !curprv.prv$v_bypass)  return FALSE;
3136     if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3137     return TRUE;
3138   }
3139   _ckvmssts(retsts);
3140
3141   return FALSE;  /* Should never get here */
3142
3143 }  /* end of cando_by_name() */
3144 /*}}}*/
3145
3146
3147 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
3148 int
3149 flex_fstat(int fd, struct stat *statbuf)
3150 {
3151   char fspec[NAM$C_MAXRSS+1];
3152
3153   if (!getname(fd,fspec,1)) return -1;
3154   return flex_stat(fspec,statbuf);
3155
3156 }  /* end of flex_fstat() */
3157 /*}}}*/
3158
3159 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
3160 /* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
3161  * 'struct stat' elsewhere in Perl would use our struct.  We go back
3162  * to the system version here, since we're actually calling their
3163  * stat().
3164  */
3165 #undef stat
3166 int
3167 flex_stat(char *fspec, struct mystat *statbufp)
3168 {
3169     char fileified[NAM$C_MAXRSS+1];
3170     int retval,myretval;
3171     struct mystat tmpbuf;
3172
3173
3174     if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
3175     if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3176       memset(statbufp,0,sizeof *statbufp);
3177       statbufp->st_dev = encode_dev("_NLA0:");
3178       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3179       statbufp->st_uid = 0x00010001;
3180       statbufp->st_gid = 0x0001;
3181       time((time_t *)&statbufp->st_mtime);
3182       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3183       return 0;
3184     }
3185
3186     if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
3187     else {
3188       myretval = stat(fileified,(stat_t *) &tmpbuf);
3189     }
3190     retval = stat(fspec,(stat_t *) statbufp);
3191     if (!myretval) {
3192       if (retval == -1) {
3193         *statbufp = tmpbuf;
3194         retval = 0;
3195       }
3196       else if (!retval) { /* Dir with same name.  Substitute it. */
3197         statbufp->st_mode &= ~S_IFDIR;
3198         statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
3199         strcpy(namecache,fileified);
3200       }
3201     }
3202     if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
3203     return retval;
3204
3205 }  /* end of flex_stat() */
3206 /* Reset definition for later calls */
3207 #define stat mystat
3208 /*}}}*/
3209
3210 /*{{{char *my_getlogin()*/
3211 /* VMS cuserid == Unix getlogin, except calling sequence */
3212 char *
3213 my_getlogin()
3214 {
3215     static char user[L_cuserid];
3216     return cuserid(user);
3217 }
3218 /*}}}*/
3219
3220
3221 /*  rmscopy - copy a file using VMS RMS routines
3222  *
3223  *  Copies contents and attributes of spec_in to spec_out, except owner
3224  *  and protection information.  Name and type of spec_in are used as
3225  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
3226  *  should try to propagate timestamps from the input file to the output file.
3227  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
3228  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
3229  *  propagated to the output file at creation iff the output file specification
3230  *  did not contain an explicit name or type, and the revision date is always
3231  *  updated at the end of the copy operation.  If it is greater than 0, then
3232  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3233  *  other than the revision date should be propagated, and bit 1 indicates
3234  *  that the revision date should be propagated.
3235  *
3236  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3237  *
3238  *  Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3239  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
3240  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
3241  * as part of the Perl standard distribution under the terms of the
3242  * GNU General Public License or the Perl Artistic License.  Copies
3243  * of each may be found in the Perl standard distribution.
3244  */
3245 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3246 int
3247 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3248 {
3249     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3250          rsa[NAM$C_MAXRSS], ubf[32256];
3251     unsigned long int i, sts, sts2;
3252     struct FAB fab_in, fab_out;
3253     struct RAB rab_in, rab_out;
3254     struct NAM nam;
3255     struct XABDAT xabdat;
3256     struct XABFHC xabfhc;
3257     struct XABRDT xabrdt;
3258     struct XABSUM xabsum;
3259
3260     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
3261         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3262       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3263       return 0;
3264     }
3265
3266     fab_in = cc$rms_fab;
3267     fab_in.fab$l_fna = vmsin;
3268     fab_in.fab$b_fns = strlen(vmsin);
3269     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3270     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3271     fab_in.fab$l_fop = FAB$M_SQO;
3272     fab_in.fab$l_nam =  &nam;
3273     fab_in.fab$l_xab = (void *) &xabdat;
3274
3275     nam = cc$rms_nam;
3276     nam.nam$l_rsa = rsa;
3277     nam.nam$b_rss = sizeof(rsa);
3278     nam.nam$l_esa = esa;
3279     nam.nam$b_ess = sizeof (esa);
3280     nam.nam$b_esl = nam.nam$b_rsl = 0;
3281
3282     xabdat = cc$rms_xabdat;        /* To get creation date */
3283     xabdat.xab$l_nxt = (void *) &xabfhc;
3284
3285     xabfhc = cc$rms_xabfhc;        /* To get record length */
3286     xabfhc.xab$l_nxt = (void *) &xabsum;
3287
3288     xabsum = cc$rms_xabsum;        /* To get key and area information */
3289
3290     if (!((sts = sys$open(&fab_in)) & 1)) {
3291       set_vaxc_errno(sts);
3292       switch (sts) {
3293         case RMS$_FNF:
3294         case RMS$_DIR:
3295           set_errno(ENOENT); break;
3296         case RMS$_DEV:
3297           set_errno(ENODEV); break;
3298         case RMS$_SYN:
3299           set_errno(EINVAL); break;
3300         case RMS$_PRV:
3301           set_errno(EACCES); break;
3302         default:
3303           set_errno(EVMSERR);
3304       }
3305       return 0;
3306     }
3307
3308     fab_out = fab_in;
3309     fab_out.fab$w_ifi = 0;
3310     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3311     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3312     fab_out.fab$l_fop = FAB$M_SQO;
3313     fab_out.fab$l_fna = vmsout;
3314     fab_out.fab$b_fns = strlen(vmsout);
3315     fab_out.fab$l_dna = nam.nam$l_name;
3316     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3317
3318     if (preserve_dates == 0) {  /* Act like DCL COPY */
3319       nam.nam$b_nop = NAM$M_SYNCHK;
3320       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
3321       if (!((sts = sys$parse(&fab_out)) & 1)) {
3322         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3323         set_vaxc_errno(sts);
3324         return 0;
3325       }
3326       fab_out.fab$l_xab = (void *) &xabdat;
3327       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3328     }
3329     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
3330     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
3331       preserve_dates =0;      /* bitmask from this point forward   */
3332
3333     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3334     if (!((sts = sys$create(&fab_out)) & 1)) {
3335       set_vaxc_errno(sts);
3336       switch (sts) {
3337         case RMS$_DIR:
3338           set_errno(ENOENT); break;
3339         case RMS$_DEV:
3340           set_errno(ENODEV); break;
3341         case RMS$_SYN:
3342           set_errno(EINVAL); break;
3343         case RMS$_PRV:
3344           set_errno(EACCES); break;
3345         default:
3346           set_errno(EVMSERR);
3347       }
3348       return 0;
3349     }
3350     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
3351     if (preserve_dates & 2) {
3352       /* sys$close() will process xabrdt, not xabdat */
3353       xabrdt = cc$rms_xabrdt;
3354       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3355       fab_out.fab$l_xab = (void *) &xabrdt;
3356     }
3357
3358     rab_in = cc$rms_rab;
3359     rab_in.rab$l_fab = &fab_in;
3360     rab_in.rab$l_rop = RAB$M_BIO;
3361     rab_in.rab$l_ubf = ubf;
3362     rab_in.rab$w_usz = sizeof ubf;
3363     if (!((sts = sys$connect(&rab_in)) & 1)) {
3364       sys$close(&fab_in); sys$close(&fab_out);
3365       set_errno(EVMSERR); set_vaxc_errno(sts);
3366       return 0;
3367     }
3368
3369     rab_out = cc$rms_rab;
3370     rab_out.rab$l_fab = &fab_out;
3371     rab_out.rab$l_rbf = ubf;
3372     if (!((sts = sys$connect(&rab_out)) & 1)) {
3373       sys$close(&fab_in); sys$close(&fab_out);
3374       set_errno(EVMSERR); set_vaxc_errno(sts);
3375       return 0;
3376     }
3377
3378     while ((sts = sys$read(&rab_in))) {  /* always true  */
3379       if (sts == RMS$_EOF) break;
3380       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3381       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3382         sys$close(&fab_in); sys$close(&fab_out);
3383         set_errno(EVMSERR); set_vaxc_errno(sts);
3384         return 0;
3385       }
3386     }
3387
3388     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
3389     sys$close(&fab_in);  sys$close(&fab_out);
3390     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3391     if (!(sts & 1)) {
3392       set_errno(EVMSERR); set_vaxc_errno(sts);
3393       return 0;
3394     }
3395
3396     return 1;
3397
3398 }  /* end of rmscopy() */
3399 /*}}}*/
3400
3401
3402 /***  The following glue provides 'hooks' to make some of the routines
3403  * from this file available from Perl.  These routines are sufficiently
3404  * basic, and are required sufficiently early in the build process,
3405  * that's it's nice to have them available to miniperl as well as the
3406  * full Perl, so they're set up here instead of in an extension.  The
3407  * Perl code which handles importation of these names into a given
3408  * package lives in [.VMS]Filespec.pm in @INC.
3409  */
3410
3411 void
3412 rmsexpand_fromperl(CV *cv)
3413 {
3414   dXSARGS;
3415   char esa[NAM$C_MAXRSS], rsa[NAM$C_MAXRSS], *cp, *out;
3416   struct FAB myfab = cc$rms_fab;
3417   struct NAM mynam = cc$rms_nam;
3418   STRLEN speclen;
3419   unsigned long int retsts, haslower = 0;
3420
3421   myfab.fab$l_fna = SvPV(ST(0),speclen);
3422   myfab.fab$b_fns = speclen;
3423   myfab.fab$l_nam = &mynam;
3424
3425   mynam.nam$l_esa = esa;
3426   mynam.nam$b_ess = sizeof esa;
3427   mynam.nam$l_rsa = rsa;
3428   mynam.nam$b_rss = sizeof rsa;
3429
3430   retsts = sys$parse(&myfab,0,0);
3431   if (!(retsts & 1)) {
3432     set_vaxc_errno(retsts);
3433     if      (retsts == RMS$_PRV) set_errno(EACCES);
3434     else if (retsts == RMS$_DEV) set_errno(ENODEV);
3435     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3436     else                         set_errno(EVMSERR);
3437     XSRETURN_UNDEF;
3438   }
3439   retsts = sys$search(&myfab,0,0);
3440   if (!(retsts & 1) && retsts != RMS$_FNF) {
3441     set_vaxc_errno(retsts);
3442     if      (retsts == RMS$_PRV) set_errno(EACCES);
3443     else                         set_errno(EVMSERR);
3444     XSRETURN_UNDEF;
3445   }
3446   /* If the input filespec contained any lowercase characters,
3447    * downcase the result for compatibility with Unix-minded code. */
3448   for (out = myfab.fab$l_fna; *out; out++)
3449     if (islower(*out)) { haslower = 1; break; }
3450   if (mynam.nam$b_rsl) { out = rsa; speclen = mynam.nam$b_rsl; }
3451   else                 { out = esa; speclen = mynam.nam$b_esl; }
3452   if (!(mynam.nam$l_fnb & NAM$M_EXP_VER))
3453     speclen = mynam.nam$l_type - out;
3454   out[speclen] = '\0';
3455   if (haslower) __mystrtolower(out);
3456
3457   ST(0) = sv_2mortal(newSVpv(out, speclen));
3458 }
3459
3460 void
3461 vmsify_fromperl(CV *cv)
3462 {
3463   dXSARGS;
3464   char *vmsified;
3465
3466   if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3467   vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3468   ST(0) = sv_newmortal();
3469   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3470   XSRETURN(1);
3471 }
3472
3473 void
3474 unixify_fromperl(CV *cv)
3475 {
3476   dXSARGS;
3477   char *unixified;
3478
3479   if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3480   unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3481   ST(0) = sv_newmortal();
3482   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3483   XSRETURN(1);
3484 }
3485
3486 void
3487 fileify_fromperl(CV *cv)
3488 {
3489   dXSARGS;
3490   char *fileified;
3491
3492   if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3493   fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3494   ST(0) = sv_newmortal();
3495   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3496   XSRETURN(1);
3497 }
3498
3499 void
3500 pathify_fromperl(CV *cv)
3501 {
3502   dXSARGS;
3503   char *pathified;
3504
3505   if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3506   pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3507   ST(0) = sv_newmortal();
3508   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3509   XSRETURN(1);
3510 }
3511
3512 void
3513 vmspath_fromperl(CV *cv)
3514 {
3515   dXSARGS;
3516   char *vmspath;
3517
3518   if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
3519   vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
3520   ST(0) = sv_newmortal();
3521   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
3522   XSRETURN(1);
3523 }
3524
3525 void
3526 unixpath_fromperl(CV *cv)
3527 {
3528   dXSARGS;
3529   char *unixpath;
3530
3531   if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
3532   unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
3533   ST(0) = sv_newmortal();
3534   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
3535   XSRETURN(1);
3536 }
3537
3538 void
3539 candelete_fromperl(CV *cv)
3540 {
3541   dXSARGS;
3542   char fspec[NAM$C_MAXRSS+1], *fsp;
3543   SV *mysv;
3544   IO *io;
3545
3546   if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
3547
3548   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3549   if (SvTYPE(mysv) == SVt_PVGV) {
3550     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
3551       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3552       ST(0) = &sv_no;
3553       XSRETURN(1);
3554     }
3555     fsp = fspec;
3556   }
3557   else {
3558     if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
3559       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3560       ST(0) = &sv_no;
3561       XSRETURN(1);
3562     }
3563   }
3564
3565   ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
3566   XSRETURN(1);
3567 }
3568
3569 void
3570 rmscopy_fromperl(CV *cv)
3571 {
3572   dXSARGS;
3573   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
3574   int date_flag;
3575   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3576                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3577   unsigned long int sts;
3578   SV *mysv;
3579   IO *io;
3580
3581   if (items < 2 || items > 3)
3582     croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
3583
3584   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3585   if (SvTYPE(mysv) == SVt_PVGV) {
3586     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
3587       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3588       ST(0) = &sv_no;
3589       XSRETURN(1);
3590     }
3591     inp = inspec;
3592   }
3593   else {
3594     if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
3595       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3596       ST(0) = &sv_no;
3597       XSRETURN(1);
3598     }
3599   }
3600   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3601   if (SvTYPE(mysv) == SVt_PVGV) {
3602     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
3603       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3604       ST(0) = &sv_no;
3605       XSRETURN(1);
3606     }
3607     outp = outspec;
3608   }
3609   else {
3610     if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
3611       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3612       ST(0) = &sv_no;
3613       XSRETURN(1);
3614     }
3615   }
3616   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
3617
3618   ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no;
3619   XSRETURN(1);
3620 }
3621
3622 void
3623 init_os_extras()
3624 {
3625   char* file = __FILE__;
3626
3627   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$");
3628   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
3629   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
3630   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
3631   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
3632   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
3633   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
3634   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
3635   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
3636   return;
3637 }
3638
3639 /*  End of vms.c */