vms/vms.c

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