vms/vms.c

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