vms/vms.c

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