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  *
2347  *  21-Jul-1994  Charles Bailey  bailey@genetics.upenn.edu
2348  *  Minor modifications to original routines.
2349  */
2350
2351     /* Number of elements in vms_versions array */
2352 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
2353
2354 /*
2355  *  Open a directory, return a handle for later use.
2356  */
2357 /*{{{ DIR *opendir(char*name) */
2358 DIR *
2359 opendir(char *name)
2360 {
2361     DIR *dd;
2362     char dir[NAM$C_MAXRSS+1];
2363
2364     /* Get memory for the handle, and the pattern. */
2365     New(7006,dd,1,DIR);
2366     if (do_tovmspath(name,dir,0) == NULL) {
2367       Safefree((char *)dd);
2368       return(NULL);
2369     }
2370     New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2371
2372     /* Fill in the fields; mainly playing with the descriptor. */
2373     (void)sprintf(dd->pattern, "%s*.*",dir);
2374     dd->context = 0;
2375     dd->count = 0;
2376     dd->vms_wantversions = 0;
2377     dd->pat.dsc$a_pointer = dd->pattern;
2378     dd->pat.dsc$w_length = strlen(dd->pattern);
2379     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2380     dd->pat.dsc$b_class = DSC$K_CLASS_S;
2381
2382     return dd;
2383 }  /* end of opendir() */
2384 /*}}}*/
2385
2386 /*
2387  *  Set the flag to indicate we want versions or not.
2388  */
2389 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2390 void
2391 vmsreaddirversions(DIR *dd, int flag)
2392 {
2393     dd->vms_wantversions = flag;
2394 }
2395 /*}}}*/
2396
2397 /*
2398  *  Free up an opened directory.
2399  */
2400 /*{{{ void closedir(DIR *dd)*/
2401 void
2402 closedir(DIR *dd)
2403 {
2404     (void)lib$find_file_end(&dd->context);
2405     Safefree(dd->pattern);
2406     Safefree((char *)dd);
2407 }
2408 /*}}}*/
2409
2410 /*
2411  *  Collect all the version numbers for the current file.
2412  */
2413 static void
2414 collectversions(dd)
2415     DIR *dd;
2416 {
2417     struct dsc$descriptor_s     pat;
2418     struct dsc$descriptor_s     res;
2419     struct dirent *e;
2420     char *p, *text, buff[sizeof dd->entry.d_name];
2421     int i;
2422     unsigned long context, tmpsts;
2423
2424     /* Convenient shorthand. */
2425     e = &dd->entry;
2426
2427     /* Add the version wildcard, ignoring the "*.*" put on before */
2428     i = strlen(dd->pattern);
2429     New(7008,text,i + e->d_namlen + 3,char);
2430     (void)strcpy(text, dd->pattern);
2431     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2432
2433     /* Set up the pattern descriptor. */
2434     pat.dsc$a_pointer = text;
2435     pat.dsc$w_length = i + e->d_namlen - 1;
2436     pat.dsc$b_dtype = DSC$K_DTYPE_T;
2437     pat.dsc$b_class = DSC$K_CLASS_S;
2438
2439     /* Set up result descriptor. */
2440     res.dsc$a_pointer = buff;
2441     res.dsc$w_length = sizeof buff - 2;
2442     res.dsc$b_dtype = DSC$K_DTYPE_T;
2443     res.dsc$b_class = DSC$K_CLASS_S;
2444
2445     /* Read files, collecting versions. */
2446     for (context = 0, e->vms_verscount = 0;
2447          e->vms_verscount < VERSIZE(e);
2448          e->vms_verscount++) {
2449         tmpsts = lib$find_file(&pat, &res, &context);
2450         if (tmpsts == RMS$_NMF || context == 0) break;
2451         _ckvmssts(tmpsts);
2452         buff[sizeof buff - 1] = '\0';
2453         if ((p = strchr(buff, ';')))
2454             e->vms_versions[e->vms_verscount] = atoi(p + 1);
2455         else
2456             e->vms_versions[e->vms_verscount] = -1;
2457     }
2458
2459     _ckvmssts(lib$find_file_end(&context));
2460     Safefree(text);
2461
2462 }  /* end of collectversions() */
2463
2464 /*
2465  *  Read the next entry from the directory.
2466  */
2467 /*{{{ struct dirent *readdir(DIR *dd)*/
2468 struct dirent *
2469 readdir(DIR *dd)
2470 {
2471     struct dsc$descriptor_s     res;
2472     char *p, buff[sizeof dd->entry.d_name];
2473     unsigned long int tmpsts;
2474
2475     /* Set up result descriptor, and get next file. */
2476     res.dsc$a_pointer = buff;
2477     res.dsc$w_length = sizeof buff - 2;
2478     res.dsc$b_dtype = DSC$K_DTYPE_T;
2479     res.dsc$b_class = DSC$K_CLASS_S;
2480     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2481     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
2482     if (!(tmpsts & 1)) {
2483       set_vaxc_errno(tmpsts);
2484       switch (tmpsts) {
2485         case RMS$_PRV:
2486           set_errno(EACCES); break;
2487         case RMS$_DEV:
2488           set_errno(ENODEV); break;
2489         case RMS$_DIR:
2490         case RMS$_FNF:
2491           set_errno(ENOENT); break;
2492         default:
2493           set_errno(EVMSERR);
2494       }
2495       return NULL;
2496     }
2497     dd->count++;
2498     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2499     buff[sizeof buff - 1] = '\0';
2500     for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2501     *p = '\0';
2502
2503     /* Skip any directory component and just copy the name. */
2504     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2505     else (void)strcpy(dd->entry.d_name, buff);
2506
2507     /* Clobber the version. */
2508     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2509
2510     dd->entry.d_namlen = strlen(dd->entry.d_name);
2511     dd->entry.vms_verscount = 0;
2512     if (dd->vms_wantversions) collectversions(dd);
2513     return &dd->entry;
2514
2515 }  /* end of readdir() */
2516 /*}}}*/
2517
2518 /*
2519  *  Return something that can be used in a seekdir later.
2520  */
2521 /*{{{ long telldir(DIR *dd)*/
2522 long
2523 telldir(DIR *dd)
2524 {
2525     return dd->count;
2526 }
2527 /*}}}*/
2528
2529 /*
2530  *  Return to a spot where we used to be.  Brute force.
2531  */
2532 /*{{{ void seekdir(DIR *dd,long count)*/
2533 void
2534 seekdir(DIR *dd, long count)
2535 {
2536     int vms_wantversions;
2537
2538     /* If we haven't done anything yet... */
2539     if (dd->count == 0)
2540         return;
2541
2542     /* Remember some state, and clear it. */
2543     vms_wantversions = dd->vms_wantversions;
2544     dd->vms_wantversions = 0;
2545     _ckvmssts(lib$find_file_end(&dd->context));
2546     dd->context = 0;
2547
2548     /* The increment is in readdir(). */
2549     for (dd->count = 0; dd->count < count; )
2550         (void)readdir(dd);
2551
2552     dd->vms_wantversions = vms_wantversions;
2553
2554 }  /* end of seekdir() */
2555 /*}}}*/
2556
2557 /* VMS subprocess management
2558  *
2559  * my_vfork() - just a vfork(), after setting a flag to record that
2560  * the current script is trying a Unix-style fork/exec.
2561  *
2562  * vms_do_aexec() and vms_do_exec() are called in response to the
2563  * perl 'exec' function.  If this follows a vfork call, then they
2564  * call out the the regular perl routines in doio.c which do an
2565  * execvp (for those who really want to try this under VMS).
2566  * Otherwise, they do exactly what the perl docs say exec should
2567  * do - terminate the current script and invoke a new command
2568  * (See below for notes on command syntax.)
2569  *
2570  * do_aspawn() and do_spawn() implement the VMS side of the perl
2571  * 'system' function.
2572  *
2573  * Note on command arguments to perl 'exec' and 'system': When handled
2574  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2575  * are concatenated to form a DCL command string.  If the first arg
2576  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2577  * the the command string is hrnded off to DCL directly.  Otherwise,
2578  * the first token of the command is taken as the filespec of an image
2579  * to run.  The filespec is expanded using a default type of '.EXE' and
2580  * the process defaults for device, directory, etc., and the resultant
2581  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2582  * the command string as parameters.  This is perhaps a bit compicated,
2583  * but I hope it will form a happy medium between what VMS folks expect
2584  * from lib$spawn and what Unix folks expect from exec.
2585  */
2586
2587 static int vfork_called;
2588
2589 /*{{{int my_vfork()*/
2590 int
2591 my_vfork()
2592 {
2593   vfork_called++;
2594   return vfork();
2595 }
2596 /*}}}*/
2597
2598
2599 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2600
2601 static void
2602 vms_execfree() {
2603   if (Cmd) {
2604     Safefree(Cmd);
2605     Cmd = Nullch;
2606   }
2607   if (VMScmd.dsc$a_pointer) {
2608     Safefree(VMScmd.dsc$a_pointer);
2609     VMScmd.dsc$w_length = 0;
2610     VMScmd.dsc$a_pointer = Nullch;
2611   }
2612 }
2613
2614 static char *
2615 setup_argstr(SV *really, SV **mark, SV **sp)
2616 {
2617   char *junk, *tmps = Nullch;
2618   register size_t cmdlen = 0;
2619   size_t rlen;
2620   register SV **idx;
2621
2622   idx = mark;
2623   if (really) {
2624     tmps = SvPV(really,rlen);
2625     if (*tmps) {
2626       cmdlen += rlen + 1;
2627       idx++;
2628     }
2629   }
2630
2631   for (idx++; idx <= sp; idx++) {
2632     if (*idx) {
2633       junk = SvPVx(*idx,rlen);
2634       cmdlen += rlen ? rlen + 1 : 0;
2635     }
2636   }
2637   New(401,Cmd,cmdlen+1,char);
2638
2639   if (tmps && *tmps) {
2640     strcpy(Cmd,tmps);
2641     mark++;
2642   }
2643   else *Cmd = '\0';
2644   while (++mark <= sp) {
2645     if (*mark) {
2646       strcat(Cmd," ");
2647       strcat(Cmd,SvPVx(*mark,na));
2648     }
2649   }
2650   return Cmd;
2651
2652 }  /* end of setup_argstr() */
2653
2654
2655 static unsigned long int
2656 setup_cmddsc(char *cmd, int check_img)
2657 {
2658   char resspec[NAM$C_MAXRSS+1];
2659   $DESCRIPTOR(defdsc,".EXE");
2660   $DESCRIPTOR(resdsc,resspec);
2661   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2662   unsigned long int cxt = 0, flags = 1, retsts;
2663   register char *s, *rest, *cp;
2664   register int isdcl = 0;
2665
2666   s = cmd;
2667   while (*s && isspace(*s)) s++;
2668   if (check_img) {
2669     if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2670       isdcl = 1;     /* no dev/dir separators (i.e. not a foreign command) */
2671       for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2672         if (*cp == ':' || *cp == '[' || *cp == '<') {
2673           isdcl = 0;
2674           break;
2675         }
2676       }
2677     }
2678   }
2679   else isdcl = 1;
2680   if (isdcl) {  /* It's a DCL command, just do it. */
2681     VMScmd.dsc$w_length = strlen(cmd);
2682     if (cmd == Cmd) {
2683        VMScmd.dsc$a_pointer = Cmd;
2684        Cmd = Nullch;  /* Don't try to free twice in vms_execfree() */
2685     }
2686     else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2687   }
2688   else {                           /* assume first token is an image spec */
2689     cmd = s;
2690     while (*s && !isspace(*s)) s++;
2691     rest = *s ? s : 0;
2692     imgdsc.dsc$a_pointer = cmd;
2693     imgdsc.dsc$w_length = s - cmd;
2694     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2695     if (!(retsts & 1)) {
2696       /* just hand off status values likely to be due to user error */
2697       if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2698           retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2699          (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2700       else { _ckvmssts(retsts); }
2701     }
2702     else {
2703       _ckvmssts(lib$find_file_end(&cxt));
2704       s = resspec;
2705       while (*s && !isspace(*s)) s++;
2706       *s = '\0';
2707       New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2708       strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2709       strcat(VMScmd.dsc$a_pointer,resspec);
2710       if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2711       VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2712     }
2713   }
2714
2715   return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2716
2717 }  /* end of setup_cmddsc() */
2718
2719
2720 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2721 bool
2722 vms_do_aexec(SV *really,SV **mark,SV **sp)
2723 {
2724   if (sp > mark) {
2725     if (vfork_called) {           /* this follows a vfork - act Unixish */
2726       vfork_called--;
2727       if (vfork_called < 0) {
2728         warn("Internal inconsistency in tracking vforks");
2729         vfork_called = 0;
2730       }
2731       else return do_aexec(really,mark,sp);
2732     }
2733                                            /* no vfork - act VMSish */
2734     return vms_do_exec(setup_argstr(really,mark,sp));
2735
2736   }
2737
2738   return FALSE;
2739 }  /* end of vms_do_aexec() */
2740 /*}}}*/
2741
2742 /* {{{bool vms_do_exec(char *cmd) */
2743 bool
2744 vms_do_exec(char *cmd)
2745 {
2746
2747   if (vfork_called) {             /* this follows a vfork - act Unixish */
2748     vfork_called--;
2749     if (vfork_called < 0) {
2750       warn("Internal inconsistency in tracking vforks");
2751       vfork_called = 0;
2752     }
2753     else return do_exec(cmd);
2754   }
2755
2756   {                               /* no vfork - act VMSish */
2757     unsigned long int retsts;
2758
2759     TAINT_ENV();
2760     TAINT_PROPER("exec");
2761     if ((retsts = setup_cmddsc(cmd,1)) & 1)
2762       retsts = lib$do_command(&VMScmd);
2763
2764     set_errno(EVMSERR);
2765     set_vaxc_errno(retsts);
2766     if (dowarn)
2767       warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2768     vms_execfree();
2769   }
2770
2771   return FALSE;
2772
2773 }  /* end of vms_do_exec() */
2774 /*}}}*/
2775
2776 unsigned long int do_spawn(char *);
2777
2778 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2779 unsigned long int
2780 do_aspawn(SV *really,SV **mark,SV **sp)
2781 {
2782   if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2783
2784   return SS$_ABORT;
2785 }  /* end of do_aspawn() */
2786 /*}}}*/
2787
2788 /* {{{unsigned long int do_spawn(char *cmd) */
2789 unsigned long int
2790 do_spawn(char *cmd)
2791 {
2792   unsigned long int substs, hadcmd = 1;
2793
2794   TAINT_ENV();
2795   TAINT_PROPER("spawn");
2796   if (!cmd || !*cmd) {
2797     hadcmd = 0;
2798     _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2799   }
2800   else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2801     _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2802   }
2803
2804   if (!(substs&1)) {
2805     set_errno(EVMSERR);
2806     set_vaxc_errno(substs);
2807     if (dowarn)
2808       warn("Can't spawn \"%s\": %s",
2809            hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2810   }
2811   vms_execfree();
2812   return substs;
2813
2814 }  /* end of do_spawn() */
2815 /*}}}*/
2816
2817 /*
2818  * A simple fwrite replacement which outputs itmsz*nitm chars without
2819  * introducing record boundaries every itmsz chars.
2820  */
2821 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2822 int
2823 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2824 {
2825   register char *cp, *end;
2826
2827   end = (char *)src + itmsz * nitm;
2828
2829   while ((char *)src <= end) {
2830     for (cp = src; cp <= end; cp++) if (!*cp) break;
2831     if (fputs(src,dest) == EOF) return EOF;
2832     if (cp < end)
2833       if (fputc('\0',dest) == EOF) return EOF;
2834     src = cp + 1;
2835   }
2836
2837   return 1;
2838
2839 }  /* end of my_fwrite() */
2840 /*}}}*/
2841
2842 /*
2843  * Here are replacements for the following Unix routines in the VMS environment:
2844  *      getpwuid    Get information for a particular UIC or UID
2845  *      getpwnam    Get information for a named user
2846  *      getpwent    Get information for each user in the rights database
2847  *      setpwent    Reset search to the start of the rights database
2848  *      endpwent    Finish searching for users in the rights database
2849  *
2850  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2851  * (defined in pwd.h), which contains the following fields:-
2852  *      struct passwd {
2853  *              char        *pw_name;    Username (in lower case)
2854  *              char        *pw_passwd;  Hashed password
2855  *              unsigned int pw_uid;     UIC
2856  *              unsigned int pw_gid;     UIC group  number
2857  *              char        *pw_unixdir; Default device/directory (VMS-style)
2858  *              char        *pw_gecos;   Owner name
2859  *              char        *pw_dir;     Default device/directory (Unix-style)
2860  *              char        *pw_shell;   Default CLI name (eg. DCL)
2861  *      };
2862  * If the specified user does not exist, getpwuid and getpwnam return NULL.
2863  *
2864  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2865  * not the UIC member number (eg. what's returned by getuid()),
2866  * getpwuid() can accept either as input (if uid is specified, the caller's
2867  * UIC group is used), though it won't recognise gid=0.
2868  *
2869  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2870  * information about other users in your group or in other groups, respectively.
2871  * If the required privilege is not available, then these routines fill only
2872  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2873  * string).
2874  *
2875  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2876  */
2877
2878 /* sizes of various UAF record fields */
2879 #define UAI$S_USERNAME 12
2880 #define UAI$S_IDENT    31
2881 #define UAI$S_OWNER    31
2882 #define UAI$S_DEFDEV   31
2883 #define UAI$S_DEFDIR   63
2884 #define UAI$S_DEFCLI   31
2885 #define UAI$S_PWD       8
2886
2887 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
2888                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2889                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
2890
2891 static char __empty[]= "";
2892 static struct passwd __passwd_empty=
2893     {(char *) __empty, (char *) __empty, 0, 0,
2894      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2895 static int contxt= 0;
2896 static struct passwd __pwdcache;
2897 static char __pw_namecache[UAI$S_IDENT+1];
2898
2899 /*
2900  * This routine does most of the work extracting the user information.
2901  */
2902 static int fillpasswd (const char *name, struct passwd *pwd)
2903 {
2904     static struct {
2905         unsigned char length;
2906         char pw_gecos[UAI$S_OWNER+1];
2907     } owner;
2908     static union uicdef uic;
2909     static struct {
2910         unsigned char length;
2911         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2912     } defdev;
2913     static struct {
2914         unsigned char length;
2915         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2916     } defdir;
2917     static struct {
2918         unsigned char length;
2919         char pw_shell[UAI$S_DEFCLI+1];
2920     } defcli;
2921     static char pw_passwd[UAI$S_PWD+1];
2922
2923     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2924     struct dsc$descriptor_s name_desc;
2925     unsigned long int sts;
2926
2927     static struct itmlst_3 itmlst[]= {
2928         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
2929         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
2930         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
2931         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
2932         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
2933         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
2934         {0,                0,           NULL,    NULL}};
2935
2936     name_desc.dsc$w_length=  strlen(name);
2937     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
2938     name_desc.dsc$b_class=   DSC$K_CLASS_S;
2939     name_desc.dsc$a_pointer= (char *) name;
2940
2941 /*  Note that sys$getuai returns many fields as counted strings. */
2942     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2943     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2944       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2945     }
2946     else { _ckvmssts(sts); }
2947     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
2948
2949     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
2950     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2951     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2952     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2953     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2954     owner.pw_gecos[lowner]=            '\0';
2955     defdev.pw_dir[ldefdev+ldefdir]= '\0';
2956     defcli.pw_shell[ldefcli]=          '\0';
2957     if (valid_uic(uic)) {
2958         pwd->pw_uid= uic.uic$l_uic;
2959         pwd->pw_gid= uic.uic$v_group;
2960     }
2961     else
2962       warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2963     pwd->pw_passwd=  pw_passwd;
2964     pwd->pw_gecos=   owner.pw_gecos;
2965     pwd->pw_dir=     defdev.pw_dir;
2966     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2967     pwd->pw_shell=   defcli.pw_shell;
2968     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2969         int ldir;
2970         ldir= strlen(pwd->pw_unixdir) - 1;
2971         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2972     }
2973     else
2974         strcpy(pwd->pw_unixdir, pwd->pw_dir);
2975     __mystrtolower(pwd->pw_unixdir);
2976     return 1;
2977 }
2978
2979 /*
2980  * Get information for a named user.
2981 */
2982 /*{{{struct passwd *getpwnam(char *name)*/
2983 struct passwd *my_getpwnam(char *name)
2984 {
2985     struct dsc$descriptor_s name_desc;
2986     union uicdef uic;
2987     unsigned long int status, sts;
2988
2989     __pwdcache = __passwd_empty;
2990     if (!fillpasswd(name, &__pwdcache)) {
2991       /* We still may be able to determine pw_uid and pw_gid */
2992       name_desc.dsc$w_length=  strlen(name);
2993       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
2994       name_desc.dsc$b_class=   DSC$K_CLASS_S;
2995       name_desc.dsc$a_pointer= (char *) name;
2996       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2997         __pwdcache.pw_uid= uic.uic$l_uic;
2998         __pwdcache.pw_gid= uic.uic$v_group;
2999       }
3000       else {
3001         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3002           set_vaxc_errno(sts);
3003           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3004           return NULL;
3005         }
3006         else { _ckvmssts(sts); }
3007       }
3008     }
3009     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3010     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3011     __pwdcache.pw_name= __pw_namecache;
3012     return &__pwdcache;
3013 }  /* end of my_getpwnam() */
3014 /*}}}*/
3015
3016 /*
3017  * Get information for a particular UIC or UID.
3018  * Called by my_getpwent with uid=-1 to list all users.
3019 */
3020 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3021 struct passwd *my_getpwuid(Uid_t uid)
3022 {
3023     const $DESCRIPTOR(name_desc,__pw_namecache);
3024     unsigned short lname;
3025     union uicdef uic;
3026     unsigned long int status;
3027
3028     if (uid == (unsigned int) -1) {
3029       do {
3030         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3031         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3032           set_vaxc_errno(status);
3033           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3034           my_endpwent();
3035           return NULL;
3036         }
3037         else { _ckvmssts(status); }
3038       } while (!valid_uic (uic));
3039     }
3040     else {
3041       uic.uic$l_uic= uid;
3042       if (!uic.uic$v_group)
3043         uic.uic$v_group= getgid();
3044       if (valid_uic(uic))
3045         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3046       else status = SS$_IVIDENT;
3047       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3048           status == RMS$_PRV) {
3049         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3050         return NULL;
3051       }
3052       else { _ckvmssts(status); }
3053     }
3054     __pw_namecache[lname]= '\0';
3055     __mystrtolower(__pw_namecache);
3056
3057     __pwdcache = __passwd_empty;
3058     __pwdcache.pw_name = __pw_namecache;
3059
3060 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3061     The identifier's value is usually the UIC, but it doesn't have to be,
3062     so if we can, we let fillpasswd update this. */
3063     __pwdcache.pw_uid =  uic.uic$l_uic;
3064     __pwdcache.pw_gid =  uic.uic$v_group;
3065
3066     fillpasswd(__pw_namecache, &__pwdcache);
3067     return &__pwdcache;
3068
3069 }  /* end of my_getpwuid() */
3070 /*}}}*/
3071
3072 /*
3073  * Get information for next user.
3074 */
3075 /*{{{struct passwd *my_getpwent()*/
3076 struct passwd *my_getpwent()
3077 {
3078     return (my_getpwuid((unsigned int) -1));
3079 }
3080 /*}}}*/
3081
3082 /*
3083  * Finish searching rights database for users.
3084 */
3085 /*{{{void my_endpwent()*/
3086 void my_endpwent()
3087 {
3088     if (contxt) {
3089       _ckvmssts(sys$finish_rdb(&contxt));
3090       contxt= 0;
3091     }
3092 }
3093 /*}}}*/
3094
3095
3096 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3097  * my_utime(), and flex_stat(), all of which operate on UTC unless
3098  * VMSISH_TIMES is true.
3099  */
3100 /* method used to handle UTC conversions:
3101  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
3102  */
3103 static int gmtime_emulation_type;
3104 /* number of secs to add to UTC POSIX-style time to get local time */
3105 static long int utc_offset_secs;
3106
3107 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3108  * in vmsish.h.  #undef them here so we can call the CRTL routines
3109  * directly.
3110  */
3111 #undef gmtime
3112 #undef localtime
3113 #undef time
3114
3115 /* my_time(), my_localtime(), my_gmtime()
3116  * By default traffic in UTC time values, suing CRTL gmtime() or
3117  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3118  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
3119  * Modified by Charles Bailey <bailey@genetics.upenn.edu>
3120  */
3121
3122 /*{{{time_t my_time(time_t *timep)*/
3123 time_t my_time(time_t *timep)
3124 {
3125   time_t when;
3126
3127   if (gmtime_emulation_type == 0) {
3128     struct tm *tm_p;
3129     time_t base = 15 * 86400; /* 15jan71; to avoid month ends */
3130
3131     gmtime_emulation_type++;
3132     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3133       char *off;
3134
3135       gmtime_emulation_type++;
3136       if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
3137         gmtime_emulation_type++;
3138         warn("no UTC offset information; assuming local time is UTC");
3139       }
3140       else { utc_offset_secs = atol(off); }
3141     }
3142     else { /* We've got a working gmtime() */
3143       struct tm gmt, local;
3144
3145       gmt = *tm_p;
3146       tm_p = localtime(&base);
3147       local = *tm_p;
3148       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
3149       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3150       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
3151       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
3152     }
3153   }
3154
3155   when = time(NULL);
3156   if (
3157 #     ifdef VMSISH_TIME
3158       !VMSISH_TIME &&
3159 #     endif
3160                        when != -1) when -= utc_offset_secs;
3161   if (timep != NULL) *timep = when;
3162   return when;
3163
3164 }  /* end of my_time() */
3165 /*}}}*/
3166
3167
3168 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3169 struct tm *
3170 my_gmtime(const time_t *timep)
3171 {
3172   char *p;
3173   time_t when;
3174
3175   if (timep == NULL) {
3176     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3177     return NULL;
3178   }
3179   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
3180   if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3181
3182   when = *timep;
3183 # ifdef VMSISH_TIME
3184   if (VMSISH_TIME) when -= utc_offset_secs; /* Input was local time */
3185 # endif
3186   /* CRTL localtime() wants local time as input, so does no tz correction */
3187   return localtime(&when);
3188
3189 }  /* end of my_gmtime() */
3190 /*}}}*/
3191
3192
3193 /*{{{struct tm *my_localtime(const time_t *timep)*/
3194 struct tm *
3195 my_localtime(const time_t *timep)
3196 {
3197   time_t when;
3198
3199   if (timep == NULL) {
3200     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3201     return NULL;
3202   }
3203   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
3204   if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3205
3206   when = *timep;
3207 # ifdef VMSISH_TIME
3208   if (!VMSISH_TIME) when += utc_offset_secs;  /*  Input was UTC */
3209 # endif
3210   /* CRTL localtime() wants local time as input, so does no tz correction */
3211   return localtime(&when);
3212
3213 } /*  end of my_localtime() */
3214 /*}}}*/
3215
3216 /* Reset definitions for later calls */
3217 #define gmtime(t)    my_gmtime(t)
3218 #define localtime(t) my_localtime(t)
3219 #define time(t)      my_time(t)
3220
3221
3222 /* my_utime - update modification time of a file
3223  * calling sequence is identical to POSIX utime(), but under
3224  * VMS only the modification time is changed; ODS-2 does not
3225  * maintain access times.  Restrictions differ from the POSIX
3226  * definition in that the time can be changed as long as the
3227  * caller has permission to execute the necessary IO$_MODIFY $QIO;
3228  * no separate checks are made to insure that the caller is the
3229  * owner of the file or has special privs enabled.
3230  * Code here is based on Joe Meadows' FILE utility.
3231  */
3232
3233 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3234  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
3235  * in 100 ns intervals.
3236  */
3237 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3238
3239 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3240 int my_utime(char *file, struct utimbuf *utimes)
3241 {
3242   register int i;
3243   long int bintime[2], len = 2, lowbit, unixtime,
3244            secscale = 10000000; /* seconds --> 100 ns intervals */
3245   unsigned long int chan, iosb[2], retsts;
3246   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3247   struct FAB myfab = cc$rms_fab;
3248   struct NAM mynam = cc$rms_nam;
3249 #if defined (__DECC) && defined (__VAX)
3250   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3251    * at least through VMS V6.1, which causes a type-conversion warning.
3252    */
3253 #  pragma message save
3254 #  pragma message disable cvtdiftypes
3255 #endif
3256   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3257   struct fibdef myfib;
3258 #if defined (__DECC) && defined (__VAX)
3259   /* This should be right after the declaration of myatr, but due
3260    * to a bug in VAX DEC C, this takes effect a statement early.
3261    */
3262 #  pragma message restore
3263 #endif
3264   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3265                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3266                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3267
3268   if (file == NULL || *file == '\0') {
3269     set_errno(ENOENT);
3270     set_vaxc_errno(LIB$_INVARG);
3271     return -1;
3272   }
3273   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3274
3275   if (utimes != NULL) {
3276     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
3277      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3278      * Since time_t is unsigned long int, and lib$emul takes a signed long int
3279      * as input, we force the sign bit to be clear by shifting unixtime right
3280      * one bit, then multiplying by an extra factor of 2 in lib$emul().
3281      */
3282     lowbit = (utimes->modtime & 1) ? secscale : 0;
3283     unixtime = (long int) utimes->modtime;
3284 #   ifdef VMSISH_TIME
3285     if (!VMSISH_TIME) {  /* Input was UTC; convert to local for sys svc */
3286       if (!gmtime_emulation_type) (void) time(NULL);  /* Initialize UTC */
3287       unixtime += utc_offset_secs;
3288     }
3289 #   endif
3290     unixtime >> 1;  secscale << 1;
3291     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3292     if (!(retsts & 1)) {
3293       set_errno(EVMSERR);
3294       set_vaxc_errno(retsts);
3295       return -1;
3296     }
3297     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3298     if (!(retsts & 1)) {
3299       set_errno(EVMSERR);
3300       set_vaxc_errno(retsts);
3301       return -1;
3302     }
3303   }
3304   else {
3305     /* Just get the current time in VMS format directly */
3306     retsts = sys$gettim(bintime);
3307     if (!(retsts & 1)) {
3308       set_errno(EVMSERR);
3309       set_vaxc_errno(retsts);
3310       return -1;
3311     }
3312   }
3313
3314   myfab.fab$l_fna = vmsspec;
3315   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3316   myfab.fab$l_nam = &mynam;
3317   mynam.nam$l_esa = esa;
3318   mynam.nam$b_ess = (unsigned char) sizeof esa;
3319   mynam.nam$l_rsa = rsa;
3320   mynam.nam$b_rss = (unsigned char) sizeof rsa;
3321
3322   /* Look for the file to be affected, letting RMS parse the file
3323    * specification for us as well.  I have set errno using only
3324    * values documented in the utime() man page for VMS POSIX.
3325    */
3326   retsts = sys$parse(&myfab,0,0);
3327   if (!(retsts & 1)) {
3328     set_vaxc_errno(retsts);
3329     if      (retsts == RMS$_PRV) set_errno(EACCES);
3330     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3331     else                         set_errno(EVMSERR);
3332     return -1;
3333   }
3334   retsts = sys$search(&myfab,0,0);
3335   if (!(retsts & 1)) {
3336     set_vaxc_errno(retsts);
3337     if      (retsts == RMS$_PRV) set_errno(EACCES);
3338     else if (retsts == RMS$_FNF) set_errno(ENOENT);
3339     else                         set_errno(EVMSERR);
3340     return -1;
3341   }
3342
3343   devdsc.dsc$w_length = mynam.nam$b_dev;
3344   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3345
3346   retsts = sys$assign(&devdsc,&chan,0,0);
3347   if (!(retsts & 1)) {
3348     set_vaxc_errno(retsts);
3349     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
3350     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
3351     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
3352     else                               set_errno(EVMSERR);
3353     return -1;
3354   }
3355
3356   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3357   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3358
3359   memset((void *) &myfib, 0, sizeof myfib);
3360 #ifdef __DECC
3361   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3362   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3363   /* This prevents the revision time of the file being reset to the current
3364    * time as a result of our IO$_MODIFY $QIO. */
3365   myfib.fib$l_acctl = FIB$M_NORECORD;
3366 #else
3367   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3368   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3369   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3370 #endif
3371   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3372   _ckvmssts(sys$dassgn(chan));
3373   if (retsts & 1) retsts = iosb[0];
3374   if (!(retsts & 1)) {
3375     set_vaxc_errno(retsts);
3376     if (retsts == SS$_NOPRIV) set_errno(EACCES);
3377     else                      set_errno(EVMSERR);
3378     return -1;
3379   }
3380
3381   return 0;
3382 }  /* end of my_utime() */
3383 /*}}}*/
3384
3385 /*
3386  * flex_stat, flex_fstat
3387  * basic stat, but gets it right when asked to stat
3388  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3389  */
3390
3391 /* encode_dev packs a VMS device name string into an integer to allow
3392  * simple comparisons. This can be used, for example, to check whether two
3393  * files are located on the same device, by comparing their encoded device
3394  * names. Even a string comparison would not do, because stat() reuses the
3395  * device name buffer for each call; so without encode_dev, it would be
3396  * necessary to save the buffer and use strcmp (this would mean a number of
3397  * changes to the standard Perl code, to say nothing of what a Perl script
3398  * would have to do.
3399  *
3400  * The device lock id, if it exists, should be unique (unless perhaps compared
3401  * with lock ids transferred from other nodes). We have a lock id if the disk is
3402  * mounted cluster-wide, which is when we tend to get long (host-qualified)
3403  * device names. Thus we use the lock id in preference, and only if that isn't
3404  * available, do we try to pack the device name into an integer (flagged by
3405  * the sign bit (LOCKID_MASK) being set).
3406  *
3407  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3408  * name and its encoded form, but it seems very unlikely that we will find
3409  * two files on different disks that share the same encoded device names,
3410  * and even more remote that they will share the same file id (if the test
3411  * is to check for the same file).
3412  *
3413  * A better method might be to use sys$device_scan on the first call, and to
3414  * search for the device, returning an index into the cached array.
3415  * The number returned would be more intelligable.
3416  * This is probably not worth it, and anyway would take quite a bit longer
3417  * on the first call.
3418  */
3419 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
3420 static mydev_t encode_dev (const char *dev)
3421 {
3422   int i;
3423   unsigned long int f;
3424   mydev_t enc;
3425   char c;
3426   const char *q;
3427
3428   if (!dev || !dev[0]) return 0;
3429
3430 #if LOCKID_MASK
3431   {
3432     struct dsc$descriptor_s dev_desc;
3433     unsigned long int status, lockid, item = DVI$_LOCKID;
3434
3435     /* For cluster-mounted disks, the disk lock identifier is unique, so we
3436        can try that first. */
3437     dev_desc.dsc$w_length =  strlen (dev);
3438     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
3439     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
3440     dev_desc.dsc$a_pointer = (char *) dev;
3441     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3442     if (lockid) return (lockid & ~LOCKID_MASK);
3443   }
3444 #endif
3445
3446   /* Otherwise we try to encode the device name */
3447   enc = 0;
3448   f = 1;
3449   i = 0;
3450   for (q = dev + strlen(dev); q--; q >= dev) {
3451     if (isdigit (*q))
3452       c= (*q) - '0';
3453     else if (isalpha (toupper (*q)))
3454       c= toupper (*q) - 'A' + (char)10;
3455     else
3456       continue; /* Skip '$'s */
3457     i++;
3458     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
3459     if (i>1) f *= 36;
3460     enc += f * (unsigned long int) c;
3461   }
3462   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
3463
3464 }  /* end of encode_dev() */
3465
3466 static char namecache[NAM$C_MAXRSS+1];
3467
3468 static int
3469 is_null_device(name)
3470     const char *name;
3471 {
3472     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3473        The underscore prefix, controller letter, and unit number are
3474        independently optional; for our purposes, the colon punctuation
3475        is not.  The colon can be trailed by optional directory and/or
3476        filename, but two consecutive colons indicates a nodename rather
3477        than a device.  [pr]  */
3478   if (*name == '_') ++name;
3479   if (tolower(*name++) != 'n') return 0;
3480   if (tolower(*name++) != 'l') return 0;
3481   if (tolower(*name) == 'a') ++name;
3482   if (*name == '0') ++name;
3483   return (*name++ == ':') && (*name != ':');
3484 }
3485
3486 /* Do the permissions allow some operation?  Assumes statcache already set. */
3487 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3488  * subset of the applicable information.  (We have to stick with struct
3489  * stat instead of struct mystat in the prototype since we have to match
3490  * the one in proto.h.)
3491  */
3492 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3493 I32
3494 cando(I32 bit, I32 effective, struct stat *statbufp)
3495 {
3496   if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
3497   else {
3498     char fname[NAM$C_MAXRSS+1];
3499     unsigned long int retsts;
3500     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3501                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3502
3503     /* If the struct mystat is stale, we're OOL; stat() overwrites the
3504        device name on successive calls */
3505     devdsc.dsc$a_pointer = ((struct mystat *)statbufp)->st_devnam;
3506     devdsc.dsc$w_length = strlen(((struct mystat *)statbufp)->st_devnam);
3507     namdsc.dsc$a_pointer = fname;
3508     namdsc.dsc$w_length = sizeof fname - 1;
3509
3510     retsts = lib$fid_to_name(&devdsc,&(((struct mystat *)statbufp)->st_ino),
3511                              &namdsc,&namdsc.dsc$w_length,0,0);
3512     if (retsts & 1) {
3513       fname[namdsc.dsc$w_length] = '\0';
3514       return cando_by_name(bit,effective,fname);
3515     }
3516     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3517       warn("Can't get filespec - stale stat buffer?\n");
3518       return FALSE;
3519     }
3520     _ckvmssts(retsts);
3521     return FALSE;  /* Should never get to here */
3522   }
3523 }  /* end of cando() */
3524 /*}}}*/
3525
3526
3527 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3528 I32
3529 cando_by_name(I32 bit, I32 effective, char *fname)
3530 {
3531   static char usrname[L_cuserid];
3532   static struct dsc$descriptor_s usrdsc =
3533          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3534   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3535   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3536   unsigned short int retlen;
3537   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3538   union prvdef curprv;
3539   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3540          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3541   struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3542          {0,0,0,0}};
3543
3544   if (!fname || !*fname) return FALSE;
3545   /* Make sure we expand logical names, since sys$check_access doesn't */
3546   if (!strpbrk(fname,"/]>:")) {
3547     strcpy(fileified,fname);
3548     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3549     fname = fileified;
3550   }
3551   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3552   retlen = namdsc.dsc$w_length = strlen(vmsname);
3553   namdsc.dsc$a_pointer = vmsname;
3554   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3555       vmsname[retlen-1] == ':') {
3556     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3557     namdsc.dsc$w_length = strlen(fileified);
3558     namdsc.dsc$a_pointer = fileified;
3559   }
3560
3561   if (!usrdsc.dsc$w_length) {
3562     cuserid(usrname);
3563     usrdsc.dsc$w_length = strlen(usrname);
3564   }
3565
3566   switch (bit) {
3567     case S_IXUSR:
3568     case S_IXGRP:
3569     case S_IXOTH:
3570       access = ARM$M_EXECUTE;
3571       break;
3572     case S_IRUSR:
3573     case S_IRGRP:
3574     case S_IROTH:
3575       access = ARM$M_READ;
3576       break;
3577     case S_IWUSR:
3578     case S_IWGRP:
3579     case S_IWOTH:
3580       access = ARM$M_WRITE;
3581       break;
3582     case S_IDUSR:
3583     case S_IDGRP:
3584     case S_IDOTH:
3585       access = ARM$M_DELETE;
3586       break;
3587     default:
3588       return FALSE;
3589   }
3590
3591   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3592   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
3593       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF    ||
3594       retsts == RMS$_DIR        || retsts == RMS$_DEV) {
3595     set_vaxc_errno(retsts);
3596     if (retsts == SS$_NOPRIV) set_errno(EACCES);
3597     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
3598     else set_errno(ENOENT);
3599     return FALSE;
3600   }
3601   if (retsts == SS$_NORMAL) {
3602     if (!privused) return TRUE;
3603     /* We can get access, but only by using privs.  Do we have the
3604        necessary privs currently enabled? */
3605     _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3606     if ((privused & CHP$M_BYPASS) &&  !curprv.prv$v_bypass)  return FALSE;
3607     if ((privused & CHP$M_SYSPRV) &&  !curprv.prv$v_sysprv &&
3608                                       !curprv.prv$v_bypass)  return FALSE;
3609     if ((privused & CHP$M_GRPPRV) &&  !curprv.prv$v_grpprv &&
3610          !curprv.prv$v_sysprv &&      !curprv.prv$v_bypass)  return FALSE;
3611     if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3612     return TRUE;
3613   }
3614   _ckvmssts(retsts);
3615
3616   return FALSE;  /* Should never get here */
3617
3618 }  /* end of cando_by_name() */
3619 /*}}}*/
3620
3621
3622 /*{{{ int flex_fstat(int fd, struct mystat *statbuf)*/
3623 int
3624 flex_fstat(int fd, struct mystat *statbufp)
3625 {
3626   if (!fstat(fd,(stat_t *) statbufp)) {
3627     if (statbufp == (struct mystat *) &statcache) *namecache == '\0';
3628     statbufp->st_dev = encode_dev(statbufp->st_devnam);
3629 #   ifdef VMSISH_TIME
3630     if (!VMSISH_TIME) { /* Return UTC instead of local time */
3631 #   else
3632     if (1) {
3633 #   endif
3634       if (!gmtime_emulation_type) (void)time(NULL);
3635       statbufp->st_mtime -= utc_offset_secs;
3636       statbufp->st_atime -= utc_offset_secs;
3637       statbufp->st_ctime -= utc_offset_secs;
3638     }
3639     return 0;
3640   }
3641   return -1;
3642
3643 }  /* end of flex_fstat() */
3644 /*}}}*/
3645
3646 /*{{{ int flex_stat(char *fspec, struct mystat *statbufp)*/
3647 int
3648 flex_stat(char *fspec, struct mystat *statbufp)
3649 {
3650     char fileified[NAM$C_MAXRSS+1];
3651     int retval = -1;
3652
3653     if (statbufp == (struct mystat *) &statcache)
3654       do_tovmsspec(fspec,namecache,0);
3655     if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3656       memset(statbufp,0,sizeof *statbufp);
3657       statbufp->st_dev = encode_dev("_NLA0:");
3658       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3659       statbufp->st_uid = 0x00010001;
3660       statbufp->st_gid = 0x0001;
3661       time((time_t *)&statbufp->st_mtime);
3662       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3663       return 0;
3664     }
3665
3666     /* Try for a directory name first.  If fspec contains a filename without
3667      * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir
3668      * and sea:[wine.dark]water. exist, we prefer the directory here.
3669      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
3670      * not sea:[wine.dark]., if the latter exists.  If the intended target is
3671      * the file with null type, specify this by calling flex_stat() with
3672      * a '.' at the end of fspec.
3673      */
3674     if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
3675       retval = stat(fileified,(stat_t *) statbufp);
3676       if (!retval && statbufp == (struct mystat *) &statcache)
3677         strcpy(namecache,fileified);
3678     }
3679     if (retval) retval = stat(fspec,(stat_t *) statbufp);
3680     if (!retval) {
3681       statbufp->st_dev = encode_dev(statbufp->st_devnam);
3682 #     ifdef VMSISH_TIME
3683       if (!VMSISH_TIME) { /* Return UTC instead of local time */
3684 #     else
3685       if (1) {
3686 #     endif
3687         if (!gmtime_emulation_type) (void)time(NULL);
3688         statbufp->st_mtime -= utc_offset_secs;
3689         statbufp->st_atime -= utc_offset_secs;
3690         statbufp->st_ctime -= utc_offset_secs;
3691       }
3692     }
3693     return retval;
3694
3695 }  /* end of flex_stat() */
3696 /*}}}*/
3697
3698 /* Insures that no carriage-control translation will be done on a file. */
3699 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3700 FILE *
3701 my_binmode(FILE *fp, char iotype)
3702 {
3703     char filespec[NAM$C_MAXRSS], *acmode;
3704     fpos_t pos;
3705
3706     if (!fgetname(fp,filespec)) return NULL;
3707     if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL;
3708     switch (iotype) {
3709       case '<': case 'r':           acmode = "rb";                      break;
3710       case '>': case 'w':
3711         /* use 'a' instead of 'w' to avoid creating new file;
3712            fsetpos below will take care of restoring file position */
3713       case 'a':                     acmode = "ab";                      break;
3714       case '+': case '|': case 's': acmode = "rb+";                     break;
3715       case '-':                     acmode = fileno(fp) ? "ab" : "rb";  break;
3716       default:
3717         warn("Unrecognized iotype %c in my_binmode",iotype);
3718         acmode = "rb+";
3719     }
3720     if (freopen(filespec,acmode,fp) == NULL) return NULL;
3721     if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL;
3722     return fp;
3723 }  /* end of my_binmode() */
3724 /*}}}*/
3725
3726
3727 /*{{{char *my_getlogin()*/
3728 /* VMS cuserid == Unix getlogin, except calling sequence */
3729 char *
3730 my_getlogin()
3731 {
3732     static char user[L_cuserid];
3733     return cuserid(user);
3734 }
3735 /*}}}*/
3736
3737
3738 /*  rmscopy - copy a file using VMS RMS routines
3739  *
3740  *  Copies contents and attributes of spec_in to spec_out, except owner
3741  *  and protection information.  Name and type of spec_in are used as
3742  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
3743  *  should try to propagate timestamps from the input file to the output file.
3744  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
3745  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
3746  *  propagated to the output file at creation iff the output file specification
3747  *  did not contain an explicit name or type, and the revision date is always
3748  *  updated at the end of the copy operation.  If it is greater than 0, then
3749  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3750  *  other than the revision date should be propagated, and bit 1 indicates
3751  *  that the revision date should be propagated.
3752  *
3753  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3754  *
3755  *  Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3756  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
3757  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
3758  * as part of the Perl standard distribution under the terms of the
3759  * GNU General Public License or the Perl Artistic License.  Copies
3760  * of each may be found in the Perl standard distribution.
3761  */
3762 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3763 int
3764 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3765 {
3766     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3767          rsa[NAM$C_MAXRSS], ubf[32256];
3768     unsigned long int i, sts, sts2;
3769     struct FAB fab_in, fab_out;
3770     struct RAB rab_in, rab_out;
3771     struct NAM nam;
3772     struct XABDAT xabdat;
3773     struct XABFHC xabfhc;
3774     struct XABRDT xabrdt;
3775     struct XABSUM xabsum;
3776
3777     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
3778         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3779       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3780       return 0;
3781     }
3782
3783     fab_in = cc$rms_fab;
3784     fab_in.fab$l_fna = vmsin;
3785     fab_in.fab$b_fns = strlen(vmsin);
3786     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3787     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3788     fab_in.fab$l_fop = FAB$M_SQO;
3789     fab_in.fab$l_nam =  &nam;
3790     fab_in.fab$l_xab = (void *) &xabdat;
3791
3792     nam = cc$rms_nam;
3793     nam.nam$l_rsa = rsa;
3794     nam.nam$b_rss = sizeof(rsa);
3795     nam.nam$l_esa = esa;
3796     nam.nam$b_ess = sizeof (esa);
3797     nam.nam$b_esl = nam.nam$b_rsl = 0;
3798
3799     xabdat = cc$rms_xabdat;        /* To get creation date */
3800     xabdat.xab$l_nxt = (void *) &xabfhc;
3801
3802     xabfhc = cc$rms_xabfhc;        /* To get record length */
3803     xabfhc.xab$l_nxt = (void *) &xabsum;
3804
3805     xabsum = cc$rms_xabsum;        /* To get key and area information */
3806
3807     if (!((sts = sys$open(&fab_in)) & 1)) {
3808       set_vaxc_errno(sts);
3809       switch (sts) {
3810         case RMS$_FNF:
3811         case RMS$_DIR:
3812           set_errno(ENOENT); break;
3813         case RMS$_DEV:
3814           set_errno(ENODEV); break;
3815         case RMS$_SYN:
3816           set_errno(EINVAL); break;
3817         case RMS$_PRV:
3818           set_errno(EACCES); break;
3819         default:
3820           set_errno(EVMSERR);
3821       }
3822       return 0;
3823     }
3824
3825     fab_out = fab_in;
3826     fab_out.fab$w_ifi = 0;
3827     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3828     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3829     fab_out.fab$l_fop = FAB$M_SQO;
3830     fab_out.fab$l_fna = vmsout;
3831     fab_out.fab$b_fns = strlen(vmsout);
3832     fab_out.fab$l_dna = nam.nam$l_name;
3833     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3834
3835     if (preserve_dates == 0) {  /* Act like DCL COPY */
3836       nam.nam$b_nop = NAM$M_SYNCHK;
3837       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
3838       if (!((sts = sys$parse(&fab_out)) & 1)) {
3839         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3840         set_vaxc_errno(sts);
3841         return 0;
3842       }
3843       fab_out.fab$l_xab = (void *) &xabdat;
3844       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3845     }
3846     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
3847     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
3848       preserve_dates =0;      /* bitmask from this point forward   */
3849
3850     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3851     if (!((sts = sys$create(&fab_out)) & 1)) {
3852       set_vaxc_errno(sts);
3853       switch (sts) {
3854         case RMS$_DIR:
3855           set_errno(ENOENT); break;
3856         case RMS$_DEV:
3857           set_errno(ENODEV); break;
3858         case RMS$_SYN:
3859           set_errno(EINVAL); break;
3860         case RMS$_PRV:
3861           set_errno(EACCES); break;
3862         default:
3863           set_errno(EVMSERR);
3864       }
3865       return 0;
3866     }
3867     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
3868     if (preserve_dates & 2) {
3869       /* sys$close() will process xabrdt, not xabdat */
3870       xabrdt = cc$rms_xabrdt;
3871 #ifndef __GNUC__
3872       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3873 #else
3874       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
3875        * is unsigned long[2], while DECC & VAXC use a struct */
3876       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
3877 #endif
3878       fab_out.fab$l_xab = (void *) &xabrdt;
3879     }
3880
3881     rab_in = cc$rms_rab;
3882     rab_in.rab$l_fab = &fab_in;
3883     rab_in.rab$l_rop = RAB$M_BIO;
3884     rab_in.rab$l_ubf = ubf;
3885     rab_in.rab$w_usz = sizeof ubf;
3886     if (!((sts = sys$connect(&rab_in)) & 1)) {
3887       sys$close(&fab_in); sys$close(&fab_out);
3888       set_errno(EVMSERR); set_vaxc_errno(sts);
3889       return 0;
3890     }
3891
3892     rab_out = cc$rms_rab;
3893     rab_out.rab$l_fab = &fab_out;
3894     rab_out.rab$l_rbf = ubf;
3895     if (!((sts = sys$connect(&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     while ((sts = sys$read(&rab_in))) {  /* always true  */
3902       if (sts == RMS$_EOF) break;
3903       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3904       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3905         sys$close(&fab_in); sys$close(&fab_out);
3906         set_errno(EVMSERR); set_vaxc_errno(sts);
3907         return 0;
3908       }
3909     }
3910
3911     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
3912     sys$close(&fab_in);  sys$close(&fab_out);
3913     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3914     if (!(sts & 1)) {
3915       set_errno(EVMSERR); set_vaxc_errno(sts);
3916       return 0;
3917     }
3918
3919     return 1;
3920
3921 }  /* end of rmscopy() */
3922 /*}}}*/
3923
3924
3925 /***  The following glue provides 'hooks' to make some of the routines
3926  * from this file available from Perl.  These routines are sufficiently
3927  * basic, and are required sufficiently early in the build process,
3928  * that's it's nice to have them available to miniperl as well as the
3929  * full Perl, so they're set up here instead of in an extension.  The
3930  * Perl code which handles importation of these names into a given
3931  * package lives in [.VMS]Filespec.pm in @INC.
3932  */
3933
3934 void
3935 rmsexpand_fromperl(CV *cv)
3936 {
3937   dXSARGS;
3938   char *fspec, *defspec = NULL, *rslt;
3939
3940   if (!items || items > 2)
3941     croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
3942   fspec = SvPV(ST(0),na);
3943   if (!fspec || !*fspec) XSRETURN_UNDEF;
3944   if (items == 2) defspec = SvPV(ST(1),na);
3945
3946   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
3947   ST(0) = sv_newmortal();
3948   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
3949   XSRETURN(1);
3950 }
3951
3952 void
3953 vmsify_fromperl(CV *cv)
3954 {
3955   dXSARGS;
3956   char *vmsified;
3957
3958   if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3959   vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3960   ST(0) = sv_newmortal();
3961   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3962   XSRETURN(1);
3963 }
3964
3965 void
3966 unixify_fromperl(CV *cv)
3967 {
3968   dXSARGS;
3969   char *unixified;
3970
3971   if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3972   unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3973   ST(0) = sv_newmortal();
3974   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3975   XSRETURN(1);
3976 }
3977
3978 void
3979 fileify_fromperl(CV *cv)
3980 {
3981   dXSARGS;
3982   char *fileified;
3983
3984   if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3985   fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3986   ST(0) = sv_newmortal();
3987   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3988   XSRETURN(1);
3989 }
3990
3991 void
3992 pathify_fromperl(CV *cv)
3993 {
3994   dXSARGS;
3995   char *pathified;
3996
3997   if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3998   pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3999   ST(0) = sv_newmortal();
4000   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4001   XSRETURN(1);
4002 }
4003
4004 void
4005 vmspath_fromperl(CV *cv)
4006 {
4007   dXSARGS;
4008   char *vmspath;
4009
4010   if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4011   vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
4012   ST(0) = sv_newmortal();
4013   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4014   XSRETURN(1);
4015 }
4016
4017 void
4018 unixpath_fromperl(CV *cv)
4019 {
4020   dXSARGS;
4021   char *unixpath;
4022
4023   if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4024   unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
4025   ST(0) = sv_newmortal();
4026   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4027   XSRETURN(1);
4028 }
4029
4030 void
4031 candelete_fromperl(CV *cv)
4032 {
4033   dXSARGS;
4034   char fspec[NAM$C_MAXRSS+1], *fsp;
4035   SV *mysv;
4036   IO *io;
4037
4038   if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4039
4040   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4041   if (SvTYPE(mysv) == SVt_PVGV) {
4042     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
4043       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4044       ST(0) = &sv_no;
4045       XSRETURN(1);
4046     }
4047     fsp = fspec;
4048   }
4049   else {
4050     if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
4051       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4052       ST(0) = &sv_no;
4053       XSRETURN(1);
4054     }
4055   }
4056
4057   ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
4058   XSRETURN(1);
4059 }
4060
4061 void
4062 rmscopy_fromperl(CV *cv)
4063 {
4064   dXSARGS;
4065   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4066   int date_flag;
4067   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4068                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4069   unsigned long int sts;
4070   SV *mysv;
4071   IO *io;
4072
4073   if (items < 2 || items > 3)
4074     croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4075
4076   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4077   if (SvTYPE(mysv) == SVt_PVGV) {
4078     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
4079       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4080       ST(0) = &sv_no;
4081       XSRETURN(1);
4082     }
4083     inp = inspec;
4084   }
4085   else {
4086     if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
4087       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4088       ST(0) = &sv_no;
4089       XSRETURN(1);
4090     }
4091   }
4092   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4093   if (SvTYPE(mysv) == SVt_PVGV) {
4094     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
4095       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4096       ST(0) = &sv_no;
4097       XSRETURN(1);
4098     }
4099     outp = outspec;
4100   }
4101   else {
4102     if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
4103       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4104       ST(0) = &sv_no;
4105       XSRETURN(1);
4106     }
4107   }
4108   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4109
4110   ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no;
4111   XSRETURN(1);
4112 }
4113
4114 void
4115 init_os_extras()
4116 {
4117   char* file = __FILE__;
4118
4119   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4120   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4121   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4122   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4123   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4124   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4125   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4126   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4127   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
4128   return;
4129 }
4130
4131 /*  End of vms.c */