vms/vms.c

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