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