vms/vms.c

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