vms/vms.c

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