vms/vms.c

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