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.uic$v_format
  43 #  define uic$v_group uic$r_uic_form.uic$v_group
  44 #  define uic$v_member uic$r_uic_form.uic$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+2+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 != '[' && *cp2 != '<') {
1211     *(cp1++) = '/';
1212   }
1213   else {  /* the VMS spec begins with directories */
1214     cp2++;
1215     if (*cp2 == ']' || *cp2 == '>') {
1216       strcpy(rslt,"./");
1217       return rslt;
1218     }
1219     else if (*cp2 == '-') {
1220       while (*cp2 == '-') {
1221         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1222         cp2++;
1223       }
1224       if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1225         if (ts) Safefree(rslt);                        /* filespecs like */
1226         set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [--foo.bar] */
1227         return NULL;
1228       }
1229       cp2++;
1230     }
1231     else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */
1232       *(cp1++) = '/';
1233       if (getcwd(tmp,sizeof tmp,1) == NULL) {
1234         if (ts) Safefree(rslt);
1235         return NULL;
1236       }
1237       do {
1238         cp3 = tmp;
1239         while (*cp3 != ':' && *cp3) cp3++;
1240         *(cp3++) = '\0';
1241         if (strchr(cp3,']') != NULL) break;
1242       } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1243       cp3 = tmp;
1244       while (*cp3) *(cp1++) = *(cp3++);
1245       *(cp1++) = '/';
1246       if (ts &&
1247           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1248         int offset = cp1 - rslt;
1249
1250         retlen = devlen + dirlen;
1251         Renew(rslt,retlen+1+2*dashes,char);
1252         cp1 = rslt + offset;
1253       }
1254     }
1255     else cp2++;
1256   }
1257   for (; cp2 <= dirend; cp2++) {
1258     if (*cp2 == ':') {
1259       *(cp1++) = '/';
1260       if (*(cp2+1) == '[') cp2++;
1261     }
1262     else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
1263     else if (*cp2 == '.') {
1264       *(cp1++) = '/';
1265       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1266         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1267                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1268         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1269             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1270       }
1271     }
1272     else if (*cp2 == '-') {
1273       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1274         while (*cp2 == '-') {
1275           cp2++;
1276           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1277         }
1278         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1279           if (ts) Safefree(rslt);                        /* filespecs like */
1280           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [--foo.bar] */
1281           return NULL;
1282         }
1283         cp2++;
1284       }
1285       else *(cp1++) = *cp2;
1286     }
1287     else *(cp1++) = *cp2;
1288   }
1289   while (*cp2) *(cp1++) = *(cp2++);
1290   *cp1 = '\0';
1291
1292   return rslt;
1293
1294 }  /* end of do_tounixspec() */
1295 /*}}}*/
1296 /* External entry points */
1297 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1298 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1299
1300 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1301 static char *do_tovmsspec(char *path, char *buf, int ts) {
1302   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1303   char *rslt, *dirend;
1304   register char *cp1, *cp2;
1305   unsigned long int infront = 0, hasdir = 1;
1306
1307   if (path == NULL) return NULL;
1308   if (buf) rslt = buf;
1309   else if (ts) New(7016,rslt,strlen(path)+9,char);
1310   else rslt = __tovmsspec_retbuf;
1311   if (strpbrk(path,"]:>") ||
1312       (dirend = strrchr(path,'/')) == NULL) {
1313     if (path[0] == '.') {
1314       if (path[1] == '\0') strcpy(rslt,"[]");
1315       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1316       else strcpy(rslt,path); /* probably garbage */
1317     }
1318     else strcpy(rslt,path);
1319     return rslt;
1320   }
1321   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.."? */
1322     if (!*(dirend+2)) dirend +=2;
1323     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1324   }
1325   cp1 = rslt;
1326   cp2 = path;
1327   if (*cp2 == '/') {
1328     char trndev[NAM$C_MAXRSS+1];
1329     int islnm, rooted;
1330     STRLEN trnend;
1331
1332     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1333     *cp1 = '\0';
1334     islnm =  my_trnlnm(rslt,trndev,0);
1335     trnend = islnm ? strlen(trndev) - 1 : 0;
1336     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1337     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1338     /* If the first element of the path is a logical name, determine
1339      * whether it has to be translated so we can add more directories. */
1340     if (!islnm || rooted) {
1341       *(cp1++) = ':';
1342       *(cp1++) = '[';
1343       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1344       else cp2++;
1345     }
1346     else {
1347       if (cp2 != dirend) {
1348         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1349         strcpy(rslt,trndev);
1350         cp1 = rslt + trnend;
1351         *(cp1++) = '.';
1352         cp2++;
1353       }
1354       else {
1355         *(cp1++) = ':';
1356         hasdir = 0;
1357       }
1358     }
1359   }
1360   else {
1361     *(cp1++) = '[';
1362     if (*cp2 == '.') {
1363       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1364         cp2 += 2;         /* skip over "./" - it's redundant */
1365         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
1366       }
1367       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1368         *(cp1++) = '-';                                 /* "../" --> "-" */
1369         cp2 += 3;
1370       }
1371       if (cp2 > dirend) cp2 = dirend;
1372     }
1373     else *(cp1++) = '.';
1374   }
1375   for (; cp2 < dirend; cp2++) {
1376     if (*cp2 == '/') {
1377       if (*(cp1-1) != '.') *(cp1++) = '.';
1378       infront = 0;
1379     }
1380     else if (!infront && *cp2 == '.') {
1381       if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
1382       else if (*(cp2+1) == '\0') { cp2++; break; }
1383       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1384         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1385         else if (*(cp1-2) == '[') *(cp1-1) = '-';
1386         else {  /* back up over previous directory name */
1387           cp1--;
1388           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1389           if (*(cp1-1) == '[') {
1390             memcpy(cp1,"000000.",7);
1391             cp1 += 7;
1392           }
1393         }
1394         cp2 += 2;
1395         if (cp2 == dirend) {
1396           if (*(cp1-1) == '.') cp1--;
1397           break;
1398         }
1399       }
1400       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
1401     }
1402     else {
1403       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
1404       if (*cp2 == '/')      *(cp1++) = '.';
1405       else if (*cp2 == '.') *(cp1++) = '_';
1406       else                  *(cp1++) =  *cp2;
1407       infront = 1;
1408     }
1409   }
1410   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1411   if (hasdir) *(cp1++) = ']';
1412   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
1413   while (*cp2) *(cp1++) = *(cp2++);
1414   *cp1 = '\0';
1415
1416   return rslt;
1417
1418 }  /* end of do_tovmsspec() */
1419 /*}}}*/
1420 /* External entry points */
1421 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1422 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1423
1424 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1425 static char *do_tovmspath(char *path, char *buf, int ts) {
1426   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1427   int vmslen;
1428   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1429
1430   if (path == NULL) return NULL;
1431   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1432   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1433   if (buf) return buf;
1434   else if (ts) {
1435     vmslen = strlen(vmsified);
1436     New(7017,cp,vmslen+1,char);
1437     memcpy(cp,vmsified,vmslen);
1438     cp[vmslen] = '\0';
1439     return cp;
1440   }
1441   else {
1442     strcpy(__tovmspath_retbuf,vmsified);
1443     return __tovmspath_retbuf;
1444   }
1445
1446 }  /* end of do_tovmspath() */
1447 /*}}}*/
1448 /* External entry points */
1449 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1450 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1451
1452
1453 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1454 static char *do_tounixpath(char *path, char *buf, int ts) {
1455   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1456   int unixlen;
1457   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1458
1459   if (path == NULL) return NULL;
1460   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1461   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1462   if (buf) return buf;
1463   else if (ts) {
1464     unixlen = strlen(unixified);
1465     New(7017,cp,unixlen+1,char);
1466     memcpy(cp,unixified,unixlen);
1467     cp[unixlen] = '\0';
1468     return cp;
1469   }
1470   else {
1471     strcpy(__tounixpath_retbuf,unixified);
1472     return __tounixpath_retbuf;
1473   }
1474
1475 }  /* end of do_tounixpath() */
1476 /*}}}*/
1477 /* External entry points */
1478 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1479 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1480
1481 /*
1482  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
1483  *
1484  *****************************************************************************
1485  *                                                                           *
1486  *  Copyright (C) 1989-1994 by                                               *
1487  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
1488  *                                                                           *
1489  *  Permission is hereby  granted for the reproduction of this software,     *
1490  *  on condition that this copyright notice is included in the reproduction, *
1491  *  and that such reproduction is not for purposes of profit or material     *
1492  *  gain.                                                                    *
1493  *                                                                           *
1494  *  27-Aug-1994 Modified for inclusion in perl5                              *
1495  *              by Charles Bailey  bailey@genetics.upenn.edu                 *
1496  *****************************************************************************
1497  */
1498
1499 /*
1500  * getredirection() is intended to aid in porting C programs
1501  * to VMS (Vax-11 C).  The native VMS environment does not support
1502  * '>' and '<' I/O redirection, or command line wild card expansion,
1503  * or a command line pipe mechanism using the '|' AND background
1504  * command execution '&'.  All of these capabilities are provided to any
1505  * C program which calls this procedure as the first thing in the
1506  * main program.
1507  * The piping mechanism will probably work with almost any 'filter' type
1508  * of program.  With suitable modification, it may useful for other
1509  * portability problems as well.
1510  *
1511  * Author:  Mark Pizzolato      mark@infocomm.com
1512  */
1513 struct list_item
1514     {
1515     struct list_item *next;
1516     char *value;
1517     };
1518
1519 static void add_item(struct list_item **head,
1520                      struct list_item **tail,
1521                      char *value,
1522                      int *count);
1523
1524 static void expand_wild_cards(char *item,
1525                               struct list_item **head,
1526                               struct list_item **tail,
1527                               int *count);
1528
1529 static int background_process(int argc, char **argv);
1530
1531 static void pipe_and_fork(char **cmargv);
1532
1533 /*{{{ void getredirection(int *ac, char ***av)*/
1534 void
1535 getredirection(int *ac, char ***av)
1536 /*
1537  * Process vms redirection arg's.  Exit if any error is seen.
1538  * If getredirection() processes an argument, it is erased
1539  * from the vector.  getredirection() returns a new argc and argv value.
1540  * In the event that a background command is requested (by a trailing "&"),
1541  * this routine creates a background subprocess, and simply exits the program.
1542  *
1543  * Warning: do not try to simplify the code for vms.  The code
1544  * presupposes that getredirection() is called before any data is
1545  * read from stdin or written to stdout.
1546  *
1547  * Normal usage is as follows:
1548  *
1549  *      main(argc, argv)
1550  *      int             argc;
1551  *      char            *argv[];
1552  *      {
1553  *              getredirection(&argc, &argv);
1554  *      }
1555  */
1556 {
1557     int                 argc = *ac;     /* Argument Count         */
1558     char                **argv = *av;   /* Argument Vector        */
1559     char                *ap;            /* Argument pointer       */
1560     int                 j;              /* argv[] index           */
1561     int                 item_count = 0; /* Count of Items in List */
1562     struct list_item    *list_head = 0; /* First Item in List       */
1563     struct list_item    *list_tail;     /* Last Item in List        */
1564     char                *in = NULL;     /* Input File Name          */
1565     char                *out = NULL;    /* Output File Name         */
1566     char                *outmode = "w"; /* Mode to Open Output File */
1567     char                *err = NULL;    /* Error File Name          */
1568     char                *errmode = "w"; /* Mode to Open Error File  */
1569     int                 cmargc = 0;     /* Piped Command Arg Count  */
1570     char                **cmargv = NULL;/* Piped Command Arg Vector */
1571
1572     /*
1573      * First handle the case where the last thing on the line ends with
1574      * a '&'.  This indicates the desire for the command to be run in a
1575      * subprocess, so we satisfy that desire.
1576      */
1577     ap = argv[argc-1];
1578     if (0 == strcmp("&", ap))
1579         exit(background_process(--argc, argv));
1580     if (*ap && '&' == ap[strlen(ap)-1])
1581         {
1582         ap[strlen(ap)-1] = '\0';
1583         exit(background_process(argc, argv));
1584         }
1585     /*
1586      * Now we handle the general redirection cases that involve '>', '>>',
1587      * '<', and pipes '|'.
1588      */
1589     for (j = 0; j < argc; ++j)
1590         {
1591         if (0 == strcmp("<", argv[j]))
1592             {
1593             if (j+1 >= argc)
1594                 {
1595                 fprintf(stderr,"No input file after < on command line");
1596                 exit(LIB$_WRONUMARG);
1597                 }
1598             in = argv[++j];
1599             continue;
1600             }
1601         if ('<' == *(ap = argv[j]))
1602             {
1603             in = 1 + ap;
1604             continue;
1605             }
1606         if (0 == strcmp(">", ap))
1607             {
1608             if (j+1 >= argc)
1609                 {
1610                 fprintf(stderr,"No output file after > on command line");
1611                 exit(LIB$_WRONUMARG);
1612                 }
1613             out = argv[++j];
1614             continue;
1615             }
1616         if ('>' == *ap)
1617             {
1618             if ('>' == ap[1])
1619                 {
1620                 outmode = "a";
1621                 if ('\0' == ap[2])
1622                     out = argv[++j];
1623                 else
1624                     out = 2 + ap;
1625                 }
1626             else
1627                 out = 1 + ap;
1628             if (j >= argc)
1629                 {
1630                 fprintf(stderr,"No output file after > or >> on command line");
1631                 exit(LIB$_WRONUMARG);
1632                 }
1633             continue;
1634             }
1635         if (('2' == *ap) && ('>' == ap[1]))
1636             {
1637             if ('>' == ap[2])
1638                 {
1639                 errmode = "a";
1640                 if ('\0' == ap[3])
1641                     err = argv[++j];
1642                 else
1643                     err = 3 + ap;
1644                 }
1645             else
1646                 if ('\0' == ap[2])
1647                     err = argv[++j];
1648                 else
1649                     err = 2 + ap;
1650             if (j >= argc)
1651                 {
1652                 fprintf(stderr,"No output file after 2> or 2>> on command line");
1653                 exit(LIB$_WRONUMARG);
1654                 }
1655             continue;
1656             }
1657         if (0 == strcmp("|", argv[j]))
1658             {
1659             if (j+1 >= argc)
1660                 {
1661                 fprintf(stderr,"No command into which to pipe on command line");
1662                 exit(LIB$_WRONUMARG);
1663                 }
1664             cmargc = argc-(j+1);
1665             cmargv = &argv[j+1];
1666             argc = j;
1667             continue;
1668             }
1669         if ('|' == *(ap = argv[j]))
1670             {
1671             ++argv[j];
1672             cmargc = argc-j;
1673             cmargv = &argv[j];
1674             argc = j;
1675             continue;
1676             }
1677         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1678         }
1679     /*
1680      * Allocate and fill in the new argument vector, Some Unix's terminate
1681      * the list with an extra null pointer.
1682      */
1683     New(7002, argv, item_count+1, char *);
1684     *av = argv;
1685     for (j = 0; j < item_count; ++j, list_head = list_head->next)
1686         argv[j] = list_head->value;
1687     *ac = item_count;
1688     if (cmargv != NULL)
1689         {
1690         if (out != NULL)
1691             {
1692             fprintf(stderr,"'|' and '>' may not both be specified on command line");
1693             exit(LIB$_INVARGORD);
1694             }
1695         pipe_and_fork(cmargv);
1696         }
1697
1698     /* Check for input from a pipe (mailbox) */
1699
1700     if (in == NULL && 1 == isapipe(0))
1701         {
1702         char mbxname[L_tmpnam];
1703         long int bufsize;
1704         long int dvi_item = DVI$_DEVBUFSIZ;
1705         $DESCRIPTOR(mbxnam, "");
1706         $DESCRIPTOR(mbxdevnam, "");
1707
1708         /* Input from a pipe, reopen it in binary mode to disable       */
1709         /* carriage control processing.                                 */
1710
1711         fgetname(stdin, mbxname,1);
1712         mbxnam.dsc$a_pointer = mbxname;
1713         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1714         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1715         mbxdevnam.dsc$a_pointer = mbxname;
1716         mbxdevnam.dsc$w_length = sizeof(mbxname);
1717         dvi_item = DVI$_DEVNAM;
1718         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1719         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1720         set_errno(0);
1721         set_vaxc_errno(1);
1722         freopen(mbxname, "rb", stdin);
1723         if (errno != 0)
1724             {
1725             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1726             exit(vaxc$errno);
1727             }
1728         }
1729     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1730         {
1731         fprintf(stderr,"Can't open input file %s as stdin",in);
1732         exit(vaxc$errno);
1733         }
1734     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1735         {
1736         fprintf(stderr,"Can't open output file %s as stdout",out);
1737         exit(vaxc$errno);
1738         }
1739     if (err != NULL) {
1740         FILE *tmperr;
1741         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1742             {
1743             fprintf(stderr,"Can't open error file %s as stderr",err);
1744             exit(vaxc$errno);
1745             }
1746             fclose(tmperr);
1747             if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
1748                 {
1749                 exit(vaxc$errno);
1750                 }
1751         }
1752 #ifdef ARGPROC_DEBUG
1753     fprintf(stderr, "Arglist:\n");
1754     for (j = 0; j < *ac;  ++j)
1755         fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
1756 #endif
1757 }  /* end of getredirection() */
1758 /*}}}*/
1759
1760 static void add_item(struct list_item **head,
1761                      struct list_item **tail,
1762                      char *value,
1763                      int *count)
1764 {
1765     if (*head == 0)
1766         {
1767         New(7003,*head,1,struct list_item);
1768         *tail = *head;
1769         }
1770     else {
1771         New(7004,(*tail)->next,1,struct list_item);
1772         *tail = (*tail)->next;
1773         }
1774     (*tail)->value = value;
1775     ++(*count);
1776 }
1777
1778 static void expand_wild_cards(char *item,
1779                               struct list_item **head,
1780                               struct list_item **tail,
1781                               int *count)
1782 {
1783 int expcount = 0;
1784 unsigned long int context = 0;
1785 int isunix = 0;
1786 char *had_version;
1787 char *had_device;
1788 int had_directory;
1789 char *devdir;
1790 char vmsspec[NAM$C_MAXRSS+1];
1791 $DESCRIPTOR(filespec, "");
1792 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
1793 $DESCRIPTOR(resultspec, "");
1794 unsigned long int zero = 0, sts;
1795
1796     if (strcspn(item, "*%") == strlen(item))
1797         {
1798         add_item(head, tail, item, count);
1799         return;
1800         }
1801     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1802     resultspec.dsc$b_class = DSC$K_CLASS_D;
1803     resultspec.dsc$a_pointer = NULL;
1804     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
1805       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1806     if (!isunix || !filespec.dsc$a_pointer)
1807       filespec.dsc$a_pointer = item;
1808     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1809     /*
1810      * Only return version specs, if the caller specified a version
1811      */
1812     had_version = strchr(item, ';');
1813     /*
1814      * Only return device and directory specs, if the caller specifed either.
1815      */
1816     had_device = strchr(item, ':');
1817     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1818
1819     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
1820                                   &defaultspec, 0, 0, &zero))))
1821         {
1822         char *string;
1823         char *c;
1824
1825         New(7005,string,resultspec.dsc$w_length+1,char);
1826         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1827         string[resultspec.dsc$w_length] = '\0';
1828         if (NULL == had_version)
1829             *((char *)strrchr(string, ';')) = '\0';
1830         if ((!had_directory) && (had_device == NULL))
1831             {
1832             if (NULL == (devdir = strrchr(string, ']')))
1833                 devdir = strrchr(string, '>');
1834             strcpy(string, devdir + 1);
1835             }
1836         /*
1837          * Be consistent with what the C RTL has already done to the rest of
1838          * the argv items and lowercase all of these names.
1839          */
1840         for (c = string; *c; ++c)
1841             if (isupper(*c))
1842                 *c = tolower(*c);
1843         if (isunix) trim_unixpath(item,string);
1844         add_item(head, tail, string, count);
1845         ++expcount;
1846         }
1847     if (sts != RMS$_NMF)
1848         {
1849         set_vaxc_errno(sts);
1850         switch (sts)
1851             {
1852             case RMS$_FNF:
1853             case RMS$_DIR:
1854                 set_errno(ENOENT); break;
1855             case RMS$_DEV:
1856                 set_errno(ENODEV); break;
1857             case RMS$_SYN:
1858                 set_errno(EINVAL); break;
1859             case RMS$_PRV:
1860                 set_errno(EACCES); break;
1861             default:
1862                 _ckvmssts(sts);
1863             }
1864         }
1865     if (expcount == 0)
1866         add_item(head, tail, item, count);
1867     _ckvmssts(lib$sfree1_dd(&resultspec));
1868     _ckvmssts(lib$find_file_end(&context));
1869 }
1870
1871 static int child_st[2];/* Event Flag set when child process completes   */
1872
1873 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
1874
1875 static unsigned long int exit_handler(int *status)
1876 {
1877 short iosb[4];
1878
1879     if (0 == child_st[0])
1880         {
1881 #ifdef ARGPROC_DEBUG
1882         fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
1883 #endif
1884         fflush(stdout);     /* Have to flush pipe for binary data to    */
1885                             /* terminate properly -- <tp@mccall.com>    */
1886         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
1887         sys$dassgn(child_chan);
1888         fclose(stdout);
1889         sys$synch(0, child_st);
1890         }
1891     return(1);
1892 }
1893
1894 static void sig_child(int chan)
1895 {
1896 #ifdef ARGPROC_DEBUG
1897     fprintf(stderr, "Child Completion AST\n");
1898 #endif
1899     if (child_st[0] == 0)
1900         child_st[0] = 1;
1901 }
1902
1903 static struct exit_control_block exit_block =
1904     {
1905     0,
1906     exit_handler,
1907     1,
1908     &exit_block.exit_status,
1909     0
1910     };
1911
1912 static void pipe_and_fork(char **cmargv)
1913 {
1914     char subcmd[2048];
1915     $DESCRIPTOR(cmddsc, "");
1916     static char mbxname[64];
1917     $DESCRIPTOR(mbxdsc, mbxname);
1918     int pid, j;
1919     unsigned long int zero = 0, one = 1;
1920
1921     strcpy(subcmd, cmargv[0]);
1922     for (j = 1; NULL != cmargv[j]; ++j)
1923         {
1924         strcat(subcmd, " \"");
1925         strcat(subcmd, cmargv[j]);
1926         strcat(subcmd, "\"");
1927         }
1928     cmddsc.dsc$a_pointer = subcmd;
1929     cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
1930
1931         create_mbx(&child_chan,&mbxdsc);
1932 #ifdef ARGPROC_DEBUG
1933     fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
1934     fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
1935 #endif
1936     _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
1937                                         0, &pid, child_st, &zero, sig_child,
1938                                         &child_chan));
1939 #ifdef ARGPROC_DEBUG
1940     fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
1941 #endif
1942     sys$dclexh(&exit_block);
1943     if (NULL == freopen(mbxname, "wb", stdout))
1944         {
1945         fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
1946         }
1947 }
1948
1949 static int background_process(int argc, char **argv)
1950 {
1951 char command[2048] = "$";
1952 $DESCRIPTOR(value, "");
1953 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
1954 static $DESCRIPTOR(null, "NLA0:");
1955 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
1956 char pidstring[80];
1957 $DESCRIPTOR(pidstr, "");
1958 int pid;
1959 unsigned long int flags = 17, one = 1, retsts;
1960
1961     strcat(command, argv[0]);
1962     while (--argc)
1963         {
1964         strcat(command, " \"");
1965         strcat(command, *(++argv));
1966         strcat(command, "\"");
1967         }
1968     value.dsc$a_pointer = command;
1969     value.dsc$w_length = strlen(value.dsc$a_pointer);
1970     _ckvmssts(lib$set_symbol(&cmd, &value));
1971     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
1972     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
1973         _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
1974     }
1975     else {
1976         _ckvmssts(retsts);
1977     }
1978 #ifdef ARGPROC_DEBUG
1979     fprintf(stderr, "%s\n", command);
1980 #endif
1981     sprintf(pidstring, "%08X", pid);
1982     fprintf(stderr, "%s\n", pidstring);
1983     pidstr.dsc$a_pointer = pidstring;
1984     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
1985     lib$set_symbol(&pidsymbol, &pidstr);
1986     return(SS$_NORMAL);
1987 }
1988 /*}}}*/
1989 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
1990
1991 /* trim_unixpath()
1992  * Trim Unix-style prefix off filespec, so it looks like what a shell
1993  * glob expansion would return (i.e. from specified prefix on, not
1994  * full path).  Note that returned filespec is Unix-style, regardless
1995  * of whether input filespec was VMS-style or Unix-style.
1996  *
1997  * Returns !=0 on success, 0 on failure.
1998  */
1999 /*{{{int trim_unixpath(char *template, char *fspec)*/
2000 int
2001 trim_unixpath(char *template, char *fspec)
2002 {
2003   char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2;
2004   register int tmplen;
2005
2006   if (strpbrk(fspec,"]>:") != NULL) {
2007     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2008     else base = unixified;
2009   }
2010   else base = fspec;
2011   for (cp2 = base; *cp2; cp2++) ;  /* Find end of filespec */
2012
2013   /* Find prefix to template consisting of path elements without wildcards */
2014   if ((cp1 = strpbrk(template,"*%?")) == NULL)
2015     for (cp1 = template; *cp1; cp1++) ;
2016   else while (cp1 >= template && *cp1 != '/') cp1--;
2017   if (cp1 == template) return 1;  /* Wildcard was up front - no prefix to clip */
2018   tmplen = cp1 - template;
2019
2020   /* Try to find template prefix on filespec */
2021   if (!memcmp(base,template,tmplen)) return 1;  /* Nothing before prefix - we're done */
2022   for (; cp2 - base > tmplen; base++) {
2023      if (*base != '/') continue;
2024      if (!memcmp(base + 1,template,tmplen)) break;
2025   }
2026   if (cp2 - base == tmplen) return 0;  /* Not there - not good */
2027   base++;  /* Move past leading '/' */
2028   /* Copy down remaining portion of filespec, including trailing NUL */
2029   memmove(fspec,base,cp2 - base + 1);
2030   return 1;
2031
2032 }  /* end of trim_unixpath() */
2033 /*}}}*/
2034
2035
2036 /*
2037  *  VMS readdir() routines.
2038  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2039  *  This code has no copyright.
2040  *
2041  *  21-Jul-1994  Charles Bailey  bailey@genetics.upenn.edu
2042  *  Minor modifications to original routines.
2043  */
2044
2045     /* Number of elements in vms_versions array */
2046 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
2047
2048 /*
2049  *  Open a directory, return a handle for later use.
2050  */
2051 /*{{{ DIR *opendir(char*name) */
2052 DIR *
2053 opendir(char *name)
2054 {
2055     DIR *dd;
2056     char dir[NAM$C_MAXRSS+1];
2057
2058     /* Get memory for the handle, and the pattern. */
2059     New(7006,dd,1,DIR);
2060     if (do_tovmspath(name,dir,0) == NULL) {
2061       Safefree((char *)dd);
2062       return(NULL);
2063     }
2064     New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2065
2066     /* Fill in the fields; mainly playing with the descriptor. */
2067     (void)sprintf(dd->pattern, "%s*.*",dir);
2068     dd->context = 0;
2069     dd->count = 0;
2070     dd->vms_wantversions = 0;
2071     dd->pat.dsc$a_pointer = dd->pattern;
2072     dd->pat.dsc$w_length = strlen(dd->pattern);
2073     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2074     dd->pat.dsc$b_class = DSC$K_CLASS_S;
2075
2076     return dd;
2077 }  /* end of opendir() */
2078 /*}}}*/
2079
2080 /*
2081  *  Set the flag to indicate we want versions or not.
2082  */
2083 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2084 void
2085 vmsreaddirversions(DIR *dd, int flag)
2086 {
2087     dd->vms_wantversions = flag;
2088 }
2089 /*}}}*/
2090
2091 /*
2092  *  Free up an opened directory.
2093  */
2094 /*{{{ void closedir(DIR *dd)*/
2095 void
2096 closedir(DIR *dd)
2097 {
2098     (void)lib$find_file_end(&dd->context);
2099     Safefree(dd->pattern);
2100     Safefree((char *)dd);
2101 }
2102 /*}}}*/
2103
2104 /*
2105  *  Collect all the version numbers for the current file.
2106  */
2107 static void
2108 collectversions(dd)
2109     DIR *dd;
2110 {
2111     struct dsc$descriptor_s     pat;
2112     struct dsc$descriptor_s     res;
2113     struct dirent *e;
2114     char *p, *text, buff[sizeof dd->entry.d_name];
2115     int i;
2116     unsigned long context, tmpsts;
2117
2118     /* Convenient shorthand. */
2119     e = &dd->entry;
2120
2121     /* Add the version wildcard, ignoring the "*.*" put on before */
2122     i = strlen(dd->pattern);
2123     New(7008,text,i + e->d_namlen + 3,char);
2124     (void)strcpy(text, dd->pattern);
2125     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2126
2127     /* Set up the pattern descriptor. */
2128     pat.dsc$a_pointer = text;
2129     pat.dsc$w_length = i + e->d_namlen - 1;
2130     pat.dsc$b_dtype = DSC$K_DTYPE_T;
2131     pat.dsc$b_class = DSC$K_CLASS_S;
2132
2133     /* Set up result descriptor. */
2134     res.dsc$a_pointer = buff;
2135     res.dsc$w_length = sizeof buff - 2;
2136     res.dsc$b_dtype = DSC$K_DTYPE_T;
2137     res.dsc$b_class = DSC$K_CLASS_S;
2138
2139     /* Read files, collecting versions. */
2140     for (context = 0, e->vms_verscount = 0;
2141          e->vms_verscount < VERSIZE(e);
2142          e->vms_verscount++) {
2143         tmpsts = lib$find_file(&pat, &res, &context);
2144         if (tmpsts == RMS$_NMF || context == 0) break;
2145         _ckvmssts(tmpsts);
2146         buff[sizeof buff - 1] = '\0';
2147         if ((p = strchr(buff, ';')))
2148             e->vms_versions[e->vms_verscount] = atoi(p + 1);
2149         else
2150             e->vms_versions[e->vms_verscount] = -1;
2151     }
2152
2153     _ckvmssts(lib$find_file_end(&context));
2154     Safefree(text);
2155
2156 }  /* end of collectversions() */
2157
2158 /*
2159  *  Read the next entry from the directory.
2160  */
2161 /*{{{ struct dirent *readdir(DIR *dd)*/
2162 struct dirent *
2163 readdir(DIR *dd)
2164 {
2165     struct dsc$descriptor_s     res;
2166     char *p, buff[sizeof dd->entry.d_name];
2167     unsigned long int tmpsts;
2168
2169     /* Set up result descriptor, and get next file. */
2170     res.dsc$a_pointer = buff;
2171     res.dsc$w_length = sizeof buff - 2;
2172     res.dsc$b_dtype = DSC$K_DTYPE_T;
2173     res.dsc$b_class = DSC$K_CLASS_S;
2174     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2175     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
2176     if (!(tmpsts & 1)) {
2177       set_vaxc_errno(tmpsts);
2178       switch (tmpsts) {
2179         case RMS$_PRV:
2180           set_errno(EACCES); break;
2181         case RMS$_DEV:
2182           set_errno(ENODEV); break;
2183         case RMS$_DIR:
2184         case RMS$_FNF:
2185           set_errno(ENOENT); break;
2186         default:
2187           set_errno(EVMSERR);
2188       }
2189       return NULL;
2190     }
2191     dd->count++;
2192     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2193     buff[sizeof buff - 1] = '\0';
2194     for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2195     *p = '\0';
2196
2197     /* Skip any directory component and just copy the name. */
2198     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2199     else (void)strcpy(dd->entry.d_name, buff);
2200
2201     /* Clobber the version. */
2202     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2203
2204     dd->entry.d_namlen = strlen(dd->entry.d_name);
2205     dd->entry.vms_verscount = 0;
2206     if (dd->vms_wantversions) collectversions(dd);
2207     return &dd->entry;
2208
2209 }  /* end of readdir() */
2210 /*}}}*/
2211
2212 /*
2213  *  Return something that can be used in a seekdir later.
2214  */
2215 /*{{{ long telldir(DIR *dd)*/
2216 long
2217 telldir(DIR *dd)
2218 {
2219     return dd->count;
2220 }
2221 /*}}}*/
2222
2223 /*
2224  *  Return to a spot where we used to be.  Brute force.
2225  */
2226 /*{{{ void seekdir(DIR *dd,long count)*/
2227 void
2228 seekdir(DIR *dd, long count)
2229 {
2230     int vms_wantversions;
2231
2232     /* If we haven't done anything yet... */
2233     if (dd->count == 0)
2234         return;
2235
2236     /* Remember some state, and clear it. */
2237     vms_wantversions = dd->vms_wantversions;
2238     dd->vms_wantversions = 0;
2239     _ckvmssts(lib$find_file_end(&dd->context));
2240     dd->context = 0;
2241
2242     /* The increment is in readdir(). */
2243     for (dd->count = 0; dd->count < count; )
2244         (void)readdir(dd);
2245
2246     dd->vms_wantversions = vms_wantversions;
2247
2248 }  /* end of seekdir() */
2249 /*}}}*/
2250
2251 /* VMS subprocess management
2252  *
2253  * my_vfork() - just a vfork(), after setting a flag to record that
2254  * the current script is trying a Unix-style fork/exec.
2255  *
2256  * vms_do_aexec() and vms_do_exec() are called in response to the
2257  * perl 'exec' function.  If this follows a vfork call, then they
2258  * call out the the regular perl routines in doio.c which do an
2259  * execvp (for those who really want to try this under VMS).
2260  * Otherwise, they do exactly what the perl docs say exec should
2261  * do - terminate the current script and invoke a new command
2262  * (See below for notes on command syntax.)
2263  *
2264  * do_aspawn() and do_spawn() implement the VMS side of the perl
2265  * 'system' function.
2266  *
2267  * Note on command arguments to perl 'exec' and 'system': When handled
2268  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2269  * are concatenated to form a DCL command string.  If the first arg
2270  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2271  * the the command string is hrnded off to DCL directly.  Otherwise,
2272  * the first token of the command is taken as the filespec of an image
2273  * to run.  The filespec is expanded using a default type of '.EXE' and
2274  * the process defaults for device, directory, etc., and the resultant
2275  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2276  * the command string as parameters.  This is perhaps a bit compicated,
2277  * but I hope it will form a happy medium between what VMS folks expect
2278  * from lib$spawn and what Unix folks expect from exec.
2279  */
2280
2281 static int vfork_called;
2282
2283 /*{{{int my_vfork()*/
2284 int
2285 my_vfork()
2286 {
2287   vfork_called++;
2288   return vfork();
2289 }
2290 /*}}}*/
2291
2292
2293 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2294
2295 static void
2296 vms_execfree() {
2297   if (Cmd) {
2298     Safefree(Cmd);
2299     Cmd = Nullch;
2300   }
2301   if (VMScmd.dsc$a_pointer) {
2302     Safefree(VMScmd.dsc$a_pointer);
2303     VMScmd.dsc$w_length = 0;
2304     VMScmd.dsc$a_pointer = Nullch;
2305   }
2306 }
2307
2308 static char *
2309 setup_argstr(SV *really, SV **mark, SV **sp)
2310 {
2311   char *junk, *tmps = Nullch;
2312   register size_t cmdlen = 0;
2313   size_t rlen;
2314   register SV **idx;
2315
2316   idx = mark;
2317   if (really) {
2318     tmps = SvPV(really,rlen);
2319     if (*tmps) {
2320       cmdlen += rlen + 1;
2321       idx++;
2322     }
2323   }
2324
2325   for (idx++; idx <= sp; idx++) {
2326     if (*idx) {
2327       junk = SvPVx(*idx,rlen);
2328       cmdlen += rlen ? rlen + 1 : 0;
2329     }
2330   }
2331   New(401,Cmd,cmdlen+1,char);
2332
2333   if (tmps && *tmps) {
2334     strcpy(Cmd,tmps);
2335     mark++;
2336   }
2337   else *Cmd = '\0';
2338   while (++mark <= sp) {
2339     if (*mark) {
2340       strcat(Cmd," ");
2341       strcat(Cmd,SvPVx(*mark,na));
2342     }
2343   }
2344   return Cmd;
2345
2346 }  /* end of setup_argstr() */
2347
2348
2349 static unsigned long int
2350 setup_cmddsc(char *cmd, int check_img)
2351 {
2352   char resspec[NAM$C_MAXRSS+1];
2353   $DESCRIPTOR(defdsc,".EXE");
2354   $DESCRIPTOR(resdsc,resspec);
2355   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2356   unsigned long int cxt = 0, flags = 1, retsts;
2357   register char *s, *rest, *cp;
2358   register int isdcl = 0;
2359
2360   s = cmd;
2361   while (*s && isspace(*s)) s++;
2362   if (check_img) {
2363     if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2364       isdcl = 1;     /* no dev/dir separators (i.e. not a foreign command) */
2365       for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2366         if (*cp == ':' || *cp == '[' || *cp == '<') {
2367           isdcl = 0;
2368           break;
2369         }
2370       }
2371     }
2372   }
2373   else isdcl = 1;
2374   if (isdcl) {  /* It's a DCL command, just do it. */
2375     VMScmd.dsc$w_length = strlen(cmd);
2376     if (cmd == Cmd) {
2377        VMScmd.dsc$a_pointer = Cmd;
2378        Cmd = Nullch;  /* Don't try to free twice in vms_execfree() */
2379     }
2380     else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2381   }
2382   else {                           /* assume first token is an image spec */
2383     cmd = s;
2384     while (*s && !isspace(*s)) s++;
2385     rest = *s ? s : 0;
2386     imgdsc.dsc$a_pointer = cmd;
2387     imgdsc.dsc$w_length = s - cmd;
2388     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2389     if (!(retsts & 1)) {
2390       /* just hand off status values likely to be due to user error */
2391       if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2392           retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2393          (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2394       else { _ckvmssts(retsts); }
2395     }
2396     else {
2397       _ckvmssts(lib$find_file_end(&cxt));
2398       s = resspec;
2399       while (*s && !isspace(*s)) s++;
2400       *s = '\0';
2401       New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2402       strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2403       strcat(VMScmd.dsc$a_pointer,resspec);
2404       if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2405       VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2406     }
2407   }
2408
2409   return SS$_NORMAL;
2410 }  /* end of setup_cmddsc() */
2411
2412 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2413 bool
2414 vms_do_aexec(SV *really,SV **mark,SV **sp)
2415 {
2416   if (sp > mark) {
2417     if (vfork_called) {           /* this follows a vfork - act Unixish */
2418       vfork_called--;
2419       if (vfork_called < 0) {
2420         warn("Internal inconsistency in tracking vforks");
2421         vfork_called = 0;
2422       }
2423       else return do_aexec(really,mark,sp);
2424     }
2425                                            /* no vfork - act VMSish */
2426     return vms_do_exec(setup_argstr(really,mark,sp));
2427
2428   }
2429
2430   return FALSE;
2431 }  /* end of vms_do_aexec() */
2432 /*}}}*/
2433
2434 /* {{{bool vms_do_exec(char *cmd) */
2435 bool
2436 vms_do_exec(char *cmd)
2437 {
2438
2439   if (vfork_called) {             /* this follows a vfork - act Unixish */
2440     vfork_called--;
2441     if (vfork_called < 0) {
2442       warn("Internal inconsistency in tracking vforks");
2443       vfork_called = 0;
2444     }
2445     else return do_exec(cmd);
2446   }
2447
2448   {                               /* no vfork - act VMSish */
2449     unsigned long int retsts;
2450
2451     if ((retsts = setup_cmddsc(cmd,1)) & 1)
2452       retsts = lib$do_command(&VMScmd);
2453
2454     set_errno(EVMSERR);
2455     set_vaxc_errno(retsts);
2456     if (dowarn)
2457       warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2458     vms_execfree();
2459   }
2460
2461   return FALSE;
2462
2463 }  /* end of vms_do_exec() */
2464 /*}}}*/
2465
2466 unsigned long int do_spawn(char *);
2467
2468 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2469 unsigned long int
2470 do_aspawn(SV *really,SV **mark,SV **sp)
2471 {
2472   if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2473
2474   return SS$_ABORT;
2475 }  /* end of do_aspawn() */
2476 /*}}}*/
2477
2478 /* {{{unsigned long int do_spawn(char *cmd) */
2479 unsigned long int
2480 do_spawn(char *cmd)
2481 {
2482   unsigned long int substs, hadcmd = 1;
2483
2484   if (!cmd || !*cmd) {
2485     hadcmd = 0;
2486     _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2487   }
2488   else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2489     _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2490   }
2491
2492   if (!(substs&1)) {
2493     set_errno(EVMSERR);
2494     set_vaxc_errno(substs);
2495     if (dowarn)
2496       warn("Can't exec \"%s\": %s",
2497            hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2498   }
2499   vms_execfree();
2500   return substs;
2501
2502 }  /* end of do_spawn() */
2503 /*}}}*/
2504
2505 /*
2506  * A simple fwrite replacement which outputs itmsz*nitm chars without
2507  * introducing record boundaries every itmsz chars.
2508  */
2509 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2510 int
2511 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2512 {
2513   register char *cp, *end;
2514
2515   end = (char *)src + itmsz * nitm;
2516
2517   while ((char *)src <= end) {
2518     for (cp = src; cp <= end; cp++) if (!*cp) break;
2519     if (fputs(src,dest) == EOF) return EOF;
2520     if (cp < end)
2521       if (fputc('\0',dest) == EOF) return EOF;
2522     src = cp + 1;
2523   }
2524
2525   return 1;
2526
2527 }  /* end of my_fwrite() */
2528 /*}}}*/
2529
2530 /*
2531  * Here are replacements for the following Unix routines in the VMS environment:
2532  *      getpwuid    Get information for a particular UIC or UID
2533  *      getpwnam    Get information for a named user
2534  *      getpwent    Get information for each user in the rights database
2535  *      setpwent    Reset search to the start of the rights database
2536  *      endpwent    Finish searching for users in the rights database
2537  *
2538  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2539  * (defined in pwd.h), which contains the following fields:-
2540  *      struct passwd {
2541  *              char        *pw_name;    Username (in lower case)
2542  *              char        *pw_passwd;  Hashed password
2543  *              unsigned int pw_uid;     UIC
2544  *              unsigned int pw_gid;     UIC group  number
2545  *              char        *pw_unixdir; Default device/directory (VMS-style)
2546  *              char        *pw_gecos;   Owner name
2547  *              char        *pw_dir;     Default device/directory (Unix-style)
2548  *              char        *pw_shell;   Default CLI name (eg. DCL)
2549  *      };
2550  * If the specified user does not exist, getpwuid and getpwnam return NULL.
2551  *
2552  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2553  * not the UIC member number (eg. what's returned by getuid()),
2554  * getpwuid() can accept either as input (if uid is specified, the caller's
2555  * UIC group is used), though it won't recognise gid=0.
2556  *
2557  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2558  * information about other users in your group or in other groups, respectively.
2559  * If the required privilege is not available, then these routines fill only
2560  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2561  * string).
2562  *
2563  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2564  */
2565
2566 /* sizes of various UAF record fields */
2567 #define UAI$S_USERNAME 12
2568 #define UAI$S_IDENT    31
2569 #define UAI$S_OWNER    31
2570 #define UAI$S_DEFDEV   31
2571 #define UAI$S_DEFDIR   63
2572 #define UAI$S_DEFCLI   31
2573 #define UAI$S_PWD       8
2574
2575 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
2576                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2577                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
2578
2579 static char __empty[]= "";
2580 static struct passwd __passwd_empty=
2581     {(char *) __empty, (char *) __empty, 0, 0,
2582      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2583 static int contxt= 0;
2584 static struct passwd __pwdcache;
2585 static char __pw_namecache[UAI$S_IDENT+1];
2586
2587 static char *_mystrtolower(char *str)
2588 {
2589   if (str) for (; *str; ++str) *str= tolower(*str);
2590   return str;
2591 }
2592
2593 /*
2594  * This routine does most of the work extracting the user information.
2595  */
2596 static int fillpasswd (const char *name, struct passwd *pwd)
2597 {
2598     static struct {
2599         unsigned char length;
2600         char pw_gecos[UAI$S_OWNER+1];
2601     } owner;
2602     static union uicdef uic;
2603     static struct {
2604         unsigned char length;
2605         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2606     } defdev;
2607     static struct {
2608         unsigned char length;
2609         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2610     } defdir;
2611     static struct {
2612         unsigned char length;
2613         char pw_shell[UAI$S_DEFCLI+1];
2614     } defcli;
2615     static char pw_passwd[UAI$S_PWD+1];
2616
2617     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2618     struct dsc$descriptor_s name_desc;
2619     unsigned long int sts;
2620
2621     static struct itmlst_3 itmlst[]= {
2622         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
2623         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
2624         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
2625         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
2626         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
2627         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
2628         {0,                0,           NULL,    NULL}};
2629
2630     name_desc.dsc$w_length=  strlen(name);
2631     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
2632     name_desc.dsc$b_class=   DSC$K_CLASS_S;
2633     name_desc.dsc$a_pointer= (char *) name;
2634
2635 /*  Note that sys$getuai returns many fields as counted strings. */
2636     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2637     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2638       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2639     }
2640     else { _ckvmssts(sts); }
2641     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
2642
2643     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
2644     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2645     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2646     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2647     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2648     owner.pw_gecos[lowner]=            '\0';
2649     defdev.pw_dir[ldefdev+ldefdir]= '\0';
2650     defcli.pw_shell[ldefcli]=          '\0';
2651     if (valid_uic(uic)) {
2652         pwd->pw_uid= uic.uic$l_uic;
2653         pwd->pw_gid= uic.uic$v_group;
2654     }
2655     else
2656       warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2657     pwd->pw_passwd=  pw_passwd;
2658     pwd->pw_gecos=   owner.pw_gecos;
2659     pwd->pw_dir=     defdev.pw_dir;
2660     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2661     pwd->pw_shell=   defcli.pw_shell;
2662     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2663         int ldir;
2664         ldir= strlen(pwd->pw_unixdir) - 1;
2665         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2666     }
2667     else
2668         strcpy(pwd->pw_unixdir, pwd->pw_dir);
2669     _mystrtolower(pwd->pw_unixdir);
2670     return 1;
2671 }
2672
2673 /*
2674  * Get information for a named user.
2675 */
2676 /*{{{struct passwd *getpwnam(char *name)*/
2677 struct passwd *my_getpwnam(char *name)
2678 {
2679     struct dsc$descriptor_s name_desc;
2680     union uicdef uic;
2681     unsigned long int status, stat;
2682
2683     __pwdcache = __passwd_empty;
2684     if (!fillpasswd(name, &__pwdcache)) {
2685       /* We still may be able to determine pw_uid and pw_gid */
2686       name_desc.dsc$w_length=  strlen(name);
2687       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
2688       name_desc.dsc$b_class=   DSC$K_CLASS_S;
2689       name_desc.dsc$a_pointer= (char *) name;
2690       if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2691         __pwdcache.pw_uid= uic.uic$l_uic;
2692         __pwdcache.pw_gid= uic.uic$v_group;
2693       }
2694       else {
2695         if (stat == SS$_NOSUCHID || stat == SS$_IVIDENT || stat == RMS$_PRV) {
2696           set_vaxc_errno(stat);
2697           set_errno(stat == RMS$_PRV ? EACCES : EINVAL);
2698           return NULL;
2699         }
2700         else { _ckvmssts(stat); }
2701       }
2702     }
2703     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
2704     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
2705     __pwdcache.pw_name= __pw_namecache;
2706     return &__pwdcache;
2707 }  /* end of my_getpwnam() */
2708 /*}}}*/
2709
2710 /*
2711  * Get information for a particular UIC or UID.
2712  * Called by my_getpwent with uid=-1 to list all users.
2713 */
2714 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
2715 struct passwd *my_getpwuid(Uid_t uid)
2716 {
2717     const $DESCRIPTOR(name_desc,__pw_namecache);
2718     unsigned short lname;
2719     union uicdef uic;
2720     unsigned long int status;
2721
2722     if (uid == (unsigned int) -1) {
2723       do {
2724         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
2725         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
2726           set_vaxc_errno(status);
2727           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2728           my_endpwent();
2729           return NULL;
2730         }
2731         else { _ckvmssts(status); }
2732       } while (!valid_uic (uic));
2733     }
2734     else {
2735       uic.uic$l_uic= uid;
2736       if (!uic.uic$v_group)
2737         uic.uic$v_group= getgid();
2738       if (valid_uic(uic))
2739         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
2740       else status = SS$_IVIDENT;
2741       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
2742           status == RMS$_PRV) {
2743         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2744         return NULL;
2745       }
2746       else { _ckvmssts(status); }
2747     }
2748     __pw_namecache[lname]= '\0';
2749     _mystrtolower(__pw_namecache);
2750
2751     __pwdcache = __passwd_empty;
2752     __pwdcache.pw_name = __pw_namecache;
2753
2754 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
2755     The identifier's value is usually the UIC, but it doesn't have to be,
2756     so if we can, we let fillpasswd update this. */
2757     __pwdcache.pw_uid =  uic.uic$l_uic;
2758     __pwdcache.pw_gid =  uic.uic$v_group;
2759
2760     fillpasswd(__pw_namecache, &__pwdcache);
2761     return &__pwdcache;
2762
2763 }  /* end of my_getpwuid() */
2764 /*}}}*/
2765
2766 /*
2767  * Get information for next user.
2768 */
2769 /*{{{struct passwd *my_getpwent()*/
2770 struct passwd *my_getpwent()
2771 {
2772     return (my_getpwuid((unsigned int) -1));
2773 }
2774 /*}}}*/
2775
2776 /*
2777  * Finish searching rights database for users.
2778 */
2779 /*{{{void my_endpwent()*/
2780 void my_endpwent()
2781 {
2782     if (contxt) {
2783       _ckvmssts(sys$finish_rdb(&contxt));
2784       contxt= 0;
2785     }
2786 }
2787 /*}}}*/
2788
2789
2790 /* my_gmtime
2791  * If the CRTL has a real gmtime(), use it, else look for the logical
2792  * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
2793  * VMS >= 6.0.  Can be manually defined under earlier versions of VMS
2794  * to translate to the number of seconds which must be added to UTC
2795  * to get to the local time of the system.
2796  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
2797  */
2798
2799 /*{{{struct tm *my_gmtime(const time_t *time)*/
2800 /* We #defined 'gmtime' as 'my_gmtime' in vmsish.h.  #undef it here
2801  * so we can call the CRTL's routine to see if it works.
2802  */
2803 #undef gmtime
2804 struct tm *
2805 my_gmtime(const time_t *time)
2806 {
2807   static int gmtime_emulation_type;
2808   static time_t utc_offset_secs;
2809   char *p;
2810   time_t when;
2811
2812   if (gmtime_emulation_type == 0) {
2813     gmtime_emulation_type++;
2814     when = 300000000;
2815     if (gmtime(&when) == NULL) {  /* CRTL gmtime() is just a stub */
2816       gmtime_emulation_type++;
2817       if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
2818         gmtime_emulation_type++;
2819       else
2820         utc_offset_secs = (time_t) atol(p);
2821     }
2822   }
2823
2824   switch (gmtime_emulation_type) {
2825     case 1:
2826       return gmtime(time);
2827     case 2:
2828       when = *time - utc_offset_secs;
2829       return localtime(&when);
2830     default:
2831       warn("gmtime not supported on this system");
2832       return NULL;
2833   }
2834 }  /* end of my_gmtime() */
2835 /* Reset definition for later calls */
2836 #define gmtime(t) my_gmtime(t)
2837 /*}}}*/
2838
2839
2840 /*
2841  * flex_stat, flex_fstat
2842  * basic stat, but gets it right when asked to stat
2843  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
2844  */
2845
2846 /* encode_dev packs a VMS device name string into an integer to allow
2847  * simple comparisons. This can be used, for example, to check whether two
2848  * files are located on the same device, by comparing their encoded device
2849  * names. Even a string comparison would not do, because stat() reuses the
2850  * device name buffer for each call; so without encode_dev, it would be
2851  * necessary to save the buffer and use strcmp (this would mean a number of
2852  * changes to the standard Perl code, to say nothing of what a Perl script
2853  * would have to do.
2854  *
2855  * The device lock id, if it exists, should be unique (unless perhaps compared
2856  * with lock ids transferred from other nodes). We have a lock id if the disk is
2857  * mounted cluster-wide, which is when we tend to get long (host-qualified)
2858  * device names. Thus we use the lock id in preference, and only if that isn't
2859  * available, do we try to pack the device name into an integer (flagged by
2860  * the sign bit (LOCKID_MASK) being set).
2861  *
2862  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
2863  * name and its encoded form, but it seems very unlikely that we will find
2864  * two files on different disks that share the same encoded device names,
2865  * and even more remote that they will share the same file id (if the test
2866  * is to check for the same file).
2867  *
2868  * A better method might be to use sys$device_scan on the first call, and to
2869  * search for the device, returning an index into the cached array.
2870  * The number returned would be more intelligable.
2871  * This is probably not worth it, and anyway would take quite a bit longer
2872  * on the first call.
2873  */
2874 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
2875 static dev_t encode_dev (const char *dev)
2876 {
2877   int i;
2878   unsigned long int f;
2879   dev_t enc;
2880   char c;
2881   const char *q;
2882
2883   if (!dev || !dev[0]) return 0;
2884
2885 #if LOCKID_MASK
2886   {
2887     struct dsc$descriptor_s dev_desc;
2888     unsigned long int status, lockid, item = DVI$_LOCKID;
2889
2890     /* For cluster-mounted disks, the disk lock identifier is unique, so we
2891        can try that first. */
2892     dev_desc.dsc$w_length =  strlen (dev);
2893     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
2894     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
2895     dev_desc.dsc$a_pointer = (char *) dev;
2896     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
2897     if (lockid) return (lockid & ~LOCKID_MASK);
2898   }
2899 #endif
2900
2901   /* Otherwise we try to encode the device name */
2902   enc = 0;
2903   f = 1;
2904   i = 0;
2905   for (q = dev + strlen(dev); q--; q >= dev) {
2906     if (isdigit (*q))
2907       c= (*q) - '0';
2908     else if (isalpha (toupper (*q)))
2909       c= toupper (*q) - 'A' + (char)10;
2910     else
2911       continue; /* Skip '$'s */
2912     i++;
2913     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
2914     if (i>1) f *= 36;
2915     enc += f * (unsigned long int) c;
2916   }
2917   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
2918
2919 }  /* end of encode_dev() */
2920
2921 static char namecache[NAM$C_MAXRSS+1];
2922
2923 static int
2924 is_null_device(name)
2925     const char *name;
2926 {
2927     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
2928        The underscore prefix, controller letter, and unit number are
2929        independently optional; for our purposes, the colon punctuation
2930        is not.  The colon can be trailed by optional directory and/or
2931        filename, but two consecutive colons indicates a nodename rather
2932        than a device.  [pr]  */
2933   if (*name == '_') ++name;
2934   if (tolower(*name++) != 'n') return 0;
2935   if (tolower(*name++) != 'l') return 0;
2936   if (tolower(*name) == 'a') ++name;
2937   if (*name == '0') ++name;
2938   return (*name++ == ':') && (*name != ':');
2939 }
2940
2941 /* Do the permissions allow some operation?  Assumes statcache already set. */
2942 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
2943  * subset of the applicable information.
2944  */
2945 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
2946 I32
2947 cando(I32 bit, I32 effective, struct stat *statbufp)
2948 {
2949   if (statbufp == &statcache)
2950     return cando_by_name(bit,effective,namecache);
2951   else {
2952     char fname[NAM$C_MAXRSS+1];
2953     unsigned long int retsts;
2954     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
2955                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2956
2957     /* If the struct mystat is stale, we're OOL; stat() overwrites the
2958        device name on successive calls */
2959     devdsc.dsc$a_pointer = statbufp->st_devnam;
2960     devdsc.dsc$w_length = strlen(statbufp->st_devnam);
2961     namdsc.dsc$a_pointer = fname;
2962     namdsc.dsc$w_length = sizeof fname - 1;
2963
2964     retsts = lib$fid_to_name(&devdsc,&(statbufp->st_ino),&namdsc,
2965                              &namdsc.dsc$w_length,0,0);
2966     if (retsts & 1) {
2967       fname[namdsc.dsc$w_length] = '\0';
2968       return cando_by_name(bit,effective,fname);
2969     }
2970     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
2971       warn("Can't get filespec - stale stat buffer?\n");
2972       return FALSE;
2973     }
2974     _ckvmssts(retsts);
2975     return FALSE;  /* Should never get to here */
2976   }
2977 }  /* end of cando() */
2978 /*}}}*/
2979
2980
2981 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
2982 I32
2983 cando_by_name(I32 bit, I32 effective, char *fname)
2984 {
2985   static char usrname[L_cuserid];
2986   static struct dsc$descriptor_s usrdsc =
2987          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
2988   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
2989   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
2990   unsigned short int retlen;
2991   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2992   union prvdef curprv;
2993   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
2994          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
2995   struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
2996          {0,0,0,0}};
2997
2998   if (!fname || !*fname) return FALSE;
2999   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3000   retlen = namdsc.dsc$w_length = strlen(vmsname);
3001   namdsc.dsc$a_pointer = vmsname;
3002   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3003       vmsname[retlen-1] == ':') {
3004     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3005     namdsc.dsc$w_length = strlen(fileified);
3006     namdsc.dsc$a_pointer = fileified;
3007   }
3008
3009   if (!usrdsc.dsc$w_length) {
3010     cuserid(usrname);
3011     usrdsc.dsc$w_length = strlen(usrname);
3012   }
3013
3014   switch (bit) {
3015     case S_IXUSR:
3016     case S_IXGRP:
3017     case S_IXOTH:
3018       access = ARM$M_EXECUTE;
3019       break;
3020     case S_IRUSR:
3021     case S_IRGRP:
3022     case S_IROTH:
3023       access = ARM$M_READ;
3024       break;
3025     case S_IWUSR:
3026     case S_IWGRP:
3027     case S_IWOTH:
3028       access = ARM$M_WRITE;
3029       break;
3030     case S_IDUSR:
3031     case S_IDGRP:
3032     case S_IDOTH:
3033       access = ARM$M_DELETE;
3034       break;
3035     default:
3036       return FALSE;
3037   }
3038
3039   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3040   if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJ || retsts == RMS$_FNF ||
3041       retsts == RMS$_DIR   || retsts == RMS$_DEV) return FALSE;
3042   if (retsts == SS$_NORMAL) {
3043     if (!privused) return TRUE;
3044     /* We can get access, but only by using privs.  Do we have the
3045        necessary privs currently enabled? */
3046     _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3047     if ((privused & CHP$M_BYPASS) &&  !curprv.prv$v_bypass)  return FALSE;
3048     if ((privused & CHP$M_SYSPRV) &&  !curprv.prv$v_sysprv &&
3049                                       !curprv.prv$v_bypass)  return FALSE;
3050     if ((privused & CHP$M_GRPPRV) &&  !curprv.prv$v_grpprv &&
3051          !curprv.prv$v_sysprv &&      !curprv.prv$v_bypass)  return FALSE;
3052     if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3053     return TRUE;
3054   }
3055   _ckvmssts(retsts);
3056
3057   return FALSE;  /* Should never get here */
3058
3059 }  /* end of cando_by_name() */
3060 /*}}}*/
3061
3062
3063 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
3064 int
3065 flex_fstat(int fd, struct stat *statbuf)
3066 {
3067   char fspec[NAM$C_MAXRSS+1];
3068
3069   if (!getname(fd,fspec,1)) return -1;
3070   return flex_stat(fspec,statbuf);
3071
3072 }  /* end of flex_fstat() */
3073 /*}}}*/
3074
3075 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
3076 /* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
3077  * 'struct stat' elsewhere in Perl would use our struct.  We go back
3078  * to the system version here, since we're actually calling their
3079  * stat().
3080  */
3081 #undef stat
3082 int
3083 flex_stat(char *fspec, struct mystat *statbufp)
3084 {
3085     char fileified[NAM$C_MAXRSS+1];
3086     int retval,myretval;
3087     struct mystat tmpbuf;
3088
3089
3090     if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
3091     if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3092       memset(statbufp,0,sizeof *statbufp);
3093       statbufp->st_dev = encode_dev("_NLA0:");
3094       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3095       statbufp->st_uid = 0x00010001;
3096       statbufp->st_gid = 0x0001;
3097       time((time_t *)&statbufp->st_mtime);
3098       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3099       return 0;
3100     }
3101
3102     if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
3103     else {
3104       myretval = stat(fileified,(stat_t *) &tmpbuf);
3105     }
3106     retval = stat(fspec,(stat_t *) statbufp);
3107     if (!myretval) {
3108       if (retval == -1) {
3109         *statbufp = tmpbuf;
3110         retval = 0;
3111       }
3112       else if (!retval) { /* Dir with same name.  Substitute it. */
3113         statbufp->st_mode &= ~S_IFDIR;
3114         statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
3115         strcpy(namecache,fileified);
3116       }
3117     }
3118     if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
3119     return retval;
3120
3121 }  /* end of flex_stat() */
3122 /* Reset definition for later calls */
3123 #define stat mystat
3124 /*}}}*/
3125
3126 /*{{{char *my_getlogin()*/
3127 /* VMS cuserid == Unix getlogin, except calling sequence */
3128 char *
3129 my_getlogin()
3130 {
3131     static char user[L_cuserid];
3132     return cuserid(user);
3133 }
3134 /*}}}*/
3135
3136
3137 /*  rmscopy - copy a file using VMS RMS routines
3138  *
3139  *  Copies contents and attributes of spec_in to spec_out, except owner
3140  *  and protection information.  Name and type of spec_in are used as
3141  *  defaults for spec_out.  Returns 1 on success; returns 0 and sets
3142  *  errno and vaxc$errno on failure.
3143  *
3144  *  Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3145  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
3146  *  <T.J.Adye@rl.ac.uk>.  Permission is given to use and distribute this
3147  *  code under the same terms as Perl itself.  (See the GNU General Public
3148  *  License or the Perl Artistic License supplied as part of the Perl
3149  *  distribution.)
3150  */
3151 /*{{{int rmscopy(char *src, char *dst)*/
3152 int
3153 rmscopy(char *spec_in, char *spec_out)
3154 {
3155     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3156          rsa[NAM$C_MAXRSS], ubf[32256];
3157     unsigned long int i, sts, sts2;
3158     struct FAB fab_in, fab_out;
3159     struct RAB rab_in, rab_out;
3160     struct NAM nam;
3161     struct XABDAT xabdat;
3162     struct XABFHC xabfhc;
3163     struct XABRDT xabrdt;
3164     struct XABSUM xabsum;
3165
3166     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
3167         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3168       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3169       return 0;
3170     }
3171
3172     fab_in = cc$rms_fab;
3173     fab_in.fab$l_fna = vmsin;
3174     fab_in.fab$b_fns = strlen(vmsin);
3175     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3176     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3177     fab_in.fab$l_fop = FAB$M_SQO;
3178     fab_in.fab$l_nam =  &nam;
3179     fab_in.fab$l_xab = (void*) &xabdat;
3180
3181     nam = cc$rms_nam;
3182     nam.nam$l_rsa = rsa;
3183     nam.nam$b_rss = sizeof(rsa);
3184     nam.nam$l_esa = esa;
3185     nam.nam$b_ess = sizeof (esa);
3186     nam.nam$b_esl = nam.nam$b_rsl = 0;
3187
3188     xabdat = cc$rms_xabdat;        /* To get creation date */
3189     xabdat.xab$l_nxt = (void*) &xabfhc;
3190
3191     xabfhc = cc$rms_xabfhc;        /* To get record length */
3192     xabfhc.xab$l_nxt = (void*) &xabsum;
3193
3194     xabsum = cc$rms_xabsum;        /* To get key and area information */
3195
3196     if (!((sts = sys$open(&fab_in)) & 1)) {
3197       set_vaxc_errno(sts);
3198       switch (sts) {
3199         case RMS$_FNF:
3200         case RMS$_DIR:
3201           set_errno(ENOENT); break;
3202         case RMS$_DEV:
3203           set_errno(ENODEV); break;
3204         case RMS$_SYN:
3205           set_errno(EINVAL); break;
3206         case RMS$_PRV:
3207           set_errno(EACCES); break;
3208         default:
3209           set_errno(EVMSERR);
3210       }
3211       return 0;
3212     }
3213
3214     fab_out = fab_in;
3215     fab_out.fab$w_ifi = 0;
3216     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3217     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3218     fab_out.fab$l_fop = FAB$M_SQO;
3219     fab_out.fab$l_fna = vmsout;
3220     fab_out.fab$b_fns = strlen(vmsout);
3221     fab_out.fab$l_dna = nam.nam$l_name;
3222     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3223     if (!((sts = sys$create(&fab_out)) & 1)) {
3224       set_vaxc_errno(sts);
3225       switch (sts) {
3226         case RMS$_DIR:
3227           set_errno(ENOENT); break;
3228         case RMS$_DEV:
3229           set_errno(ENODEV); break;
3230         case RMS$_SYN:
3231           set_errno(EINVAL); break;
3232         case RMS$_PRV:
3233           set_errno(EACCES); break;
3234         default:
3235           set_errno(EVMSERR);
3236       }
3237       return 0;
3238     }
3239     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
3240     /* sys$close() will process xabrdt, not xabdat */
3241     xabrdt = cc$rms_xabrdt;
3242     xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3243     fab_out.fab$l_xab = &xabrdt;
3244
3245     rab_in = cc$rms_rab;
3246     rab_in.rab$l_fab = &fab_in;
3247     rab_in.rab$l_rop = RAB$M_BIO;
3248     rab_in.rab$l_ubf = ubf;
3249     rab_in.rab$w_usz = sizeof ubf;
3250     if (!((sts = sys$connect(&rab_in)) & 1)) {
3251       sys$close(&fab_in); sys$close(&fab_out);
3252       set_errno(EVMSERR); set_vaxc_errno(sts);
3253       return 0;
3254     }
3255
3256     rab_out = cc$rms_rab;
3257     rab_out.rab$l_fab = &fab_out;
3258     rab_out.rab$l_rbf = ubf;
3259     if (!((sts = sys$connect(&rab_out)) & 1)) {
3260       sys$close(&fab_in); sys$close(&fab_out);
3261       set_errno(EVMSERR); set_vaxc_errno(sts);
3262       return 0;
3263     }
3264
3265     while ((sts = sys$read(&rab_in))) {  /* always true  */
3266       if (sts == RMS$_EOF) break;
3267       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3268       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3269         sys$close(&fab_in); sys$close(&fab_out);
3270         set_errno(EVMSERR); set_vaxc_errno(sts);
3271         return 0;
3272       }
3273     }
3274
3275     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
3276     sys$close(&fab_in);  sys$close(&fab_out);
3277     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3278     if (!(sts & 1)) {
3279       set_errno(EVMSERR); set_vaxc_errno(sts);
3280       return 0;
3281     }
3282
3283     return 1;
3284
3285 }  /* end of rmscopy() */
3286 /*}}}*/
3287
3288
3289 /***  The following glue provides 'hooks' to make some of the routines
3290  * from this file available from Perl.  These routines are sufficiently
3291  * basic, and are required sufficiently early in the build process,
3292  * that's it's nice to have them available to miniperl as well as the
3293  * full Perl, so they're set up here instead of in an extension.  The
3294  * Perl code which handles importation of these names into a given
3295  * package lives in [.VMS]Filespec.pm in @INC.
3296  */
3297
3298 void
3299 vmsify_fromperl(CV *cv)
3300 {
3301   dXSARGS;
3302   char *vmsified;
3303
3304   if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3305   vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3306   ST(0) = sv_newmortal();
3307   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3308   XSRETURN(1);
3309 }
3310
3311 void
3312 unixify_fromperl(CV *cv)
3313 {
3314   dXSARGS;
3315   char *unixified;
3316
3317   if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3318   unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3319   ST(0) = sv_newmortal();
3320   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3321   XSRETURN(1);
3322 }
3323
3324 void
3325 fileify_fromperl(CV *cv)
3326 {
3327   dXSARGS;
3328   char *fileified;
3329
3330   if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3331   fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3332   ST(0) = sv_newmortal();
3333   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3334   XSRETURN(1);
3335 }
3336
3337 void
3338 pathify_fromperl(CV *cv)
3339 {
3340   dXSARGS;
3341   char *pathified;
3342
3343   if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3344   pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3345   ST(0) = sv_newmortal();
3346   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3347   XSRETURN(1);
3348 }
3349
3350 void
3351 vmspath_fromperl(CV *cv)
3352 {
3353   dXSARGS;
3354   char *vmspath;
3355
3356   if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
3357   vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
3358   ST(0) = sv_newmortal();
3359   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
3360   XSRETURN(1);
3361 }
3362
3363 void
3364 unixpath_fromperl(CV *cv)
3365 {
3366   dXSARGS;
3367   char *unixpath;
3368
3369   if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
3370   unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
3371   ST(0) = sv_newmortal();
3372   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
3373   XSRETURN(1);
3374 }
3375
3376 void
3377 candelete_fromperl(CV *cv)
3378 {
3379   dXSARGS;
3380   char fspec[NAM$C_MAXRSS+1], *fsp;
3381   SV *mysv;
3382   IO *io;
3383
3384   if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
3385
3386   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3387   if (SvTYPE(mysv) == SVt_PVGV) {
3388     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
3389       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3390       ST(0) = &sv_no;
3391       XSRETURN(1);
3392     }
3393     fsp = fspec;
3394   }
3395   else {
3396     if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
3397       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3398       ST(0) = &sv_no;
3399       XSRETURN(1);
3400     }
3401   }
3402
3403   ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
3404   XSRETURN(1);
3405 }
3406
3407 void
3408 rmscopy_fromperl(CV *cv)
3409 {
3410   dXSARGS;
3411   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
3412   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3413                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3414   unsigned long int sts;
3415   SV *mysv;
3416   IO *io;
3417
3418   if (items != 2) croak("Usage: File::Copy::rmscopy(from,to)");
3419
3420   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3421   if (SvTYPE(mysv) == SVt_PVGV) {
3422     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
3423       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3424       ST(0) = &sv_no;
3425       XSRETURN(1);
3426     }
3427     inp = inspec;
3428   }
3429   else {
3430     if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
3431       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3432       ST(0) = &sv_no;
3433       XSRETURN(1);
3434     }
3435   }
3436   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3437   if (SvTYPE(mysv) == SVt_PVGV) {
3438     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
3439       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3440       ST(0) = &sv_no;
3441       XSRETURN(1);
3442     }
3443     outp = outspec;
3444   }
3445   else {
3446     if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
3447       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3448       ST(0) = &sv_no;
3449       XSRETURN(1);
3450     }
3451   }
3452
3453   ST(0) = rmscopy(inp,outp) ? &sv_yes : &sv_no;
3454   XSRETURN(1);
3455 }
3456
3457 void
3458 init_os_extras()
3459 {
3460   char* file = __FILE__;
3461
3462   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
3463   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
3464   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
3465   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
3466   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
3467   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
3468   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
3469   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
3470   return;
3471 }
3472
3473 /*  End of vms.c */