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