vms/vms.c

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