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 (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3176
3177   when = *timep;
3178 # ifdef VMSISH_TIME
3179   if (VMSISH_TIME) when -= utc_offset_secs; /* Input was local time */
3180 # endif
3181   /* CRTL localtime() wants local time as input, so does no tz correction */
3182   return localtime(&when);
3183
3184 }  /* end of my_gmtime() */
3185 /*}}}*/
3186
3187
3188 /*{{{struct tm *my_localtime(const time_t *timep)*/
3189 struct tm *
3190 my_localtime(const time_t *timep)
3191 {
3192   time_t when;
3193
3194   if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3195
3196   when = *timep;
3197 # ifdef VMSISH_TIME
3198   if (!VMSISH_TIME) when += utc_offset_secs;  /*  Input was UTC */
3199 # endif
3200   /* CRTL localtime() wants local time as input, so does no tz correction */
3201   return localtime(&when);
3202
3203 } /*  end of my_localtime() */
3204 /*}}}*/
3205
3206 /* Reset definitions for later calls */
3207 #define gmtime(t)    my_gmtime(t)
3208 #define localtime(t) my_localtime(t)
3209 #define time(t)      my_time(t)
3210
3211
3212 /* my_utime - update modification time of a file
3213  * calling sequence is identical to POSIX utime(), but under
3214  * VMS only the modification time is changed; ODS-2 does not
3215  * maintain access times.  Restrictions differ from the POSIX
3216  * definition in that the time can be changed as long as the
3217  * caller has permission to execute the necessary IO$_MODIFY $QIO;
3218  * no separate checks are made to insure that the caller is the
3219  * owner of the file or has special privs enabled.
3220  * Code here is based on Joe Meadows' FILE utility.
3221  */
3222
3223 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3224  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
3225  * in 100 ns intervals.
3226  */
3227 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3228
3229 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3230 int my_utime(char *file, struct utimbuf *utimes)
3231 {
3232   register int i;
3233   long int bintime[2], len = 2, lowbit, unixtime,
3234            secscale = 10000000; /* seconds --> 100 ns intervals */
3235   unsigned long int chan, iosb[2], retsts;
3236   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3237   struct FAB myfab = cc$rms_fab;
3238   struct NAM mynam = cc$rms_nam;
3239 #if defined (__DECC) && defined (__VAX)
3240   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3241    * at least through VMS V6.1, which causes a type-conversion warning.
3242    */
3243 #  pragma message save
3244 #  pragma message disable cvtdiftypes
3245 #endif
3246   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3247   struct fibdef myfib;
3248 #if defined (__DECC) && defined (__VAX)
3249   /* This should be right after the declaration of myatr, but due
3250    * to a bug in VAX DEC C, this takes effect a statement early.
3251    */
3252 #  pragma message restore
3253 #endif
3254   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3255                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3256                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3257
3258   if (file == NULL || *file == '\0') {
3259     set_errno(ENOENT);
3260     set_vaxc_errno(LIB$_INVARG);
3261     return -1;
3262   }
3263   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3264
3265   if (utimes != NULL) {
3266     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
3267      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3268      * Since time_t is unsigned long int, and lib$emul takes a signed long int
3269      * as input, we force the sign bit to be clear by shifting unixtime right
3270      * one bit, then multiplying by an extra factor of 2 in lib$emul().
3271      */
3272     lowbit = (utimes->modtime & 1) ? secscale : 0;
3273     unixtime = (long int) utimes->modtime;
3274 #   ifdef VMSISH_TIME
3275     if (!VMSISH_TIME) {  /* Input was UTC; convert to local for sys svc */
3276       if (!gmtime_emulation_type) (void) time(NULL);  /* Initialize UTC */
3277       unixtime += utc_offset_secs;
3278     }
3279 #   endif
3280     unixtime >> 1;  secscale << 1;
3281     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3282     if (!(retsts & 1)) {
3283       set_errno(EVMSERR);
3284       set_vaxc_errno(retsts);
3285       return -1;
3286     }
3287     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3288     if (!(retsts & 1)) {
3289       set_errno(EVMSERR);
3290       set_vaxc_errno(retsts);
3291       return -1;
3292     }
3293   }
3294   else {
3295     /* Just get the current time in VMS format directly */
3296     retsts = sys$gettim(bintime);
3297     if (!(retsts & 1)) {
3298       set_errno(EVMSERR);
3299       set_vaxc_errno(retsts);
3300       return -1;
3301     }
3302   }
3303
3304   myfab.fab$l_fna = vmsspec;
3305   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3306   myfab.fab$l_nam = &mynam;
3307   mynam.nam$l_esa = esa;
3308   mynam.nam$b_ess = (unsigned char) sizeof esa;
3309   mynam.nam$l_rsa = rsa;
3310   mynam.nam$b_rss = (unsigned char) sizeof rsa;
3311
3312   /* Look for the file to be affected, letting RMS parse the file
3313    * specification for us as well.  I have set errno using only
3314    * values documented in the utime() man page for VMS POSIX.
3315    */
3316   retsts = sys$parse(&myfab,0,0);
3317   if (!(retsts & 1)) {
3318     set_vaxc_errno(retsts);
3319     if      (retsts == RMS$_PRV) set_errno(EACCES);
3320     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3321     else                         set_errno(EVMSERR);
3322     return -1;
3323   }
3324   retsts = sys$search(&myfab,0,0);
3325   if (!(retsts & 1)) {
3326     set_vaxc_errno(retsts);
3327     if      (retsts == RMS$_PRV) set_errno(EACCES);
3328     else if (retsts == RMS$_FNF) set_errno(ENOENT);
3329     else                         set_errno(EVMSERR);
3330     return -1;
3331   }
3332
3333   devdsc.dsc$w_length = mynam.nam$b_dev;
3334   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3335
3336   retsts = sys$assign(&devdsc,&chan,0,0);
3337   if (!(retsts & 1)) {
3338     set_vaxc_errno(retsts);
3339     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
3340     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
3341     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
3342     else                               set_errno(EVMSERR);
3343     return -1;
3344   }
3345
3346   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3347   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3348
3349   memset((void *) &myfib, 0, sizeof myfib);
3350 #ifdef __DECC
3351   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3352   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3353   /* This prevents the revision time of the file being reset to the current
3354    * time as a result of our IO$_MODIFY $QIO. */
3355   myfib.fib$l_acctl = FIB$M_NORECORD;
3356 #else
3357   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3358   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3359   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3360 #endif
3361   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3362   _ckvmssts(sys$dassgn(chan));
3363   if (retsts & 1) retsts = iosb[0];
3364   if (!(retsts & 1)) {
3365     set_vaxc_errno(retsts);
3366     if (retsts == SS$_NOPRIV) set_errno(EACCES);
3367     else                      set_errno(EVMSERR);
3368     return -1;
3369   }
3370
3371   return 0;
3372 }  /* end of my_utime() */
3373 /*}}}*/
3374
3375 /*
3376  * flex_stat, flex_fstat
3377  * basic stat, but gets it right when asked to stat
3378  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3379  */
3380
3381 /* encode_dev packs a VMS device name string into an integer to allow
3382  * simple comparisons. This can be used, for example, to check whether two
3383  * files are located on the same device, by comparing their encoded device
3384  * names. Even a string comparison would not do, because stat() reuses the
3385  * device name buffer for each call; so without encode_dev, it would be
3386  * necessary to save the buffer and use strcmp (this would mean a number of
3387  * changes to the standard Perl code, to say nothing of what a Perl script
3388  * would have to do.
3389  *
3390  * The device lock id, if it exists, should be unique (unless perhaps compared
3391  * with lock ids transferred from other nodes). We have a lock id if the disk is
3392  * mounted cluster-wide, which is when we tend to get long (host-qualified)
3393  * device names. Thus we use the lock id in preference, and only if that isn't
3394  * available, do we try to pack the device name into an integer (flagged by
3395  * the sign bit (LOCKID_MASK) being set).
3396  *
3397  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3398  * name and its encoded form, but it seems very unlikely that we will find
3399  * two files on different disks that share the same encoded device names,
3400  * and even more remote that they will share the same file id (if the test
3401  * is to check for the same file).
3402  *
3403  * A better method might be to use sys$device_scan on the first call, and to
3404  * search for the device, returning an index into the cached array.
3405  * The number returned would be more intelligable.
3406  * This is probably not worth it, and anyway would take quite a bit longer
3407  * on the first call.
3408  */
3409 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
3410 static mydev_t encode_dev (const char *dev)
3411 {
3412   int i;
3413   unsigned long int f;
3414   mydev_t enc;
3415   char c;
3416   const char *q;
3417
3418   if (!dev || !dev[0]) return 0;
3419
3420 #if LOCKID_MASK
3421   {
3422     struct dsc$descriptor_s dev_desc;
3423     unsigned long int status, lockid, item = DVI$_LOCKID;
3424
3425     /* For cluster-mounted disks, the disk lock identifier is unique, so we
3426        can try that first. */
3427     dev_desc.dsc$w_length =  strlen (dev);
3428     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
3429     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
3430     dev_desc.dsc$a_pointer = (char *) dev;
3431     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3432     if (lockid) return (lockid & ~LOCKID_MASK);
3433   }
3434 #endif
3435
3436   /* Otherwise we try to encode the device name */
3437   enc = 0;
3438   f = 1;
3439   i = 0;
3440   for (q = dev + strlen(dev); q--; q >= dev) {
3441     if (isdigit (*q))
3442       c= (*q) - '0';
3443     else if (isalpha (toupper (*q)))
3444       c= toupper (*q) - 'A' + (char)10;
3445     else
3446       continue; /* Skip '$'s */
3447     i++;
3448     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
3449     if (i>1) f *= 36;
3450     enc += f * (unsigned long int) c;
3451   }
3452   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
3453
3454 }  /* end of encode_dev() */
3455
3456 static char namecache[NAM$C_MAXRSS+1];
3457
3458 static int
3459 is_null_device(name)
3460     const char *name;
3461 {
3462     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3463        The underscore prefix, controller letter, and unit number are
3464        independently optional; for our purposes, the colon punctuation
3465        is not.  The colon can be trailed by optional directory and/or
3466        filename, but two consecutive colons indicates a nodename rather
3467        than a device.  [pr]  */
3468   if (*name == '_') ++name;
3469   if (tolower(*name++) != 'n') return 0;
3470   if (tolower(*name++) != 'l') return 0;
3471   if (tolower(*name) == 'a') ++name;
3472   if (*name == '0') ++name;
3473   return (*name++ == ':') && (*name != ':');
3474 }
3475
3476 /* Do the permissions allow some operation?  Assumes statcache already set. */
3477 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3478  * subset of the applicable information.  (We have to stick with struct
3479  * stat instead of struct mystat in the prototype since we have to match
3480  * the one in proto.h.)
3481  */
3482 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3483 I32
3484 cando(I32 bit, I32 effective, struct stat *statbufp)
3485 {
3486   if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
3487   else {
3488     char fname[NAM$C_MAXRSS+1];
3489     unsigned long int retsts;
3490     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3491                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3492
3493     /* If the struct mystat is stale, we're OOL; stat() overwrites the
3494        device name on successive calls */
3495     devdsc.dsc$a_pointer = ((struct mystat *)statbufp)->st_devnam;
3496     devdsc.dsc$w_length = strlen(((struct mystat *)statbufp)->st_devnam);
3497     namdsc.dsc$a_pointer = fname;
3498     namdsc.dsc$w_length = sizeof fname - 1;
3499
3500     retsts = lib$fid_to_name(&devdsc,&(((struct mystat *)statbufp)->st_ino),
3501                              &namdsc,&namdsc.dsc$w_length,0,0);
3502     if (retsts & 1) {
3503       fname[namdsc.dsc$w_length] = '\0';
3504       return cando_by_name(bit,effective,fname);
3505     }
3506     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3507       warn("Can't get filespec - stale stat buffer?\n");
3508       return FALSE;
3509     }
3510     _ckvmssts(retsts);
3511     return FALSE;  /* Should never get to here */
3512   }
3513 }  /* end of cando() */
3514 /*}}}*/
3515
3516
3517 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3518 I32
3519 cando_by_name(I32 bit, I32 effective, char *fname)
3520 {
3521   static char usrname[L_cuserid];
3522   static struct dsc$descriptor_s usrdsc =
3523          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3524   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3525   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3526   unsigned short int retlen;
3527   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3528   union prvdef curprv;
3529   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3530          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3531   struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3532          {0,0,0,0}};
3533
3534   if (!fname || !*fname) return FALSE;
3535   /* Make sure we expand logical names, since sys$check_access doesn't */
3536   if (!strpbrk(fname,"/]>:")) {
3537     strcpy(fileified,fname);
3538     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3539     fname = fileified;
3540   }
3541   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3542   retlen = namdsc.dsc$w_length = strlen(vmsname);
3543   namdsc.dsc$a_pointer = vmsname;
3544   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3545       vmsname[retlen-1] == ':') {
3546     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3547     namdsc.dsc$w_length = strlen(fileified);
3548     namdsc.dsc$a_pointer = fileified;
3549   }
3550
3551   if (!usrdsc.dsc$w_length) {
3552     cuserid(usrname);
3553     usrdsc.dsc$w_length = strlen(usrname);
3554   }
3555
3556   switch (bit) {
3557     case S_IXUSR:
3558     case S_IXGRP:
3559     case S_IXOTH:
3560       access = ARM$M_EXECUTE;
3561       break;
3562     case S_IRUSR:
3563     case S_IRGRP:
3564     case S_IROTH:
3565       access = ARM$M_READ;
3566       break;
3567     case S_IWUSR:
3568     case S_IWGRP:
3569     case S_IWOTH:
3570       access = ARM$M_WRITE;
3571       break;
3572     case S_IDUSR:
3573     case S_IDGRP:
3574     case S_IDOTH:
3575       access = ARM$M_DELETE;
3576       break;
3577     default:
3578       return FALSE;
3579   }
3580
3581   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3582   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
3583       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF    ||
3584       retsts == RMS$_DIR        || retsts == RMS$_DEV) {
3585     set_vaxc_errno(retsts);
3586     if (retsts == SS$_NOPRIV) set_errno(EACCES);
3587     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
3588     else set_errno(ENOENT);
3589     return FALSE;
3590   }
3591   if (retsts == SS$_NORMAL) {
3592     if (!privused) return TRUE;
3593     /* We can get access, but only by using privs.  Do we have the
3594        necessary privs currently enabled? */
3595     _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3596     if ((privused & CHP$M_BYPASS) &&  !curprv.prv$v_bypass)  return FALSE;
3597     if ((privused & CHP$M_SYSPRV) &&  !curprv.prv$v_sysprv &&
3598                                       !curprv.prv$v_bypass)  return FALSE;
3599     if ((privused & CHP$M_GRPPRV) &&  !curprv.prv$v_grpprv &&
3600          !curprv.prv$v_sysprv &&      !curprv.prv$v_bypass)  return FALSE;
3601     if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3602     return TRUE;
3603   }
3604   _ckvmssts(retsts);
3605
3606   return FALSE;  /* Should never get here */
3607
3608 }  /* end of cando_by_name() */
3609 /*}}}*/
3610
3611
3612 /*{{{ int flex_fstat(int fd, struct mystat *statbuf)*/
3613 int
3614 flex_fstat(int fd, struct mystat *statbufp)
3615 {
3616   if (!fstat(fd,(stat_t *) statbufp)) {
3617     if (statbufp == (struct mystat *) &statcache) *namecache == '\0';
3618     statbufp->st_dev = encode_dev(statbufp->st_devnam);
3619 #   ifdef VMSISH_TIME
3620     if (!VMSISH_TIME) { /* Return UTC instead of local time */
3621 #   else
3622     if (1) {
3623 #   endif
3624       if (!gmtime_emulation_type) (void)time(NULL);
3625       statbufp->st_mtime -= utc_offset_secs;
3626       statbufp->st_atime -= utc_offset_secs;
3627       statbufp->st_ctime -= utc_offset_secs;
3628     }
3629     return 0;
3630   }
3631   return -1;
3632
3633 }  /* end of flex_fstat() */
3634 /*}}}*/
3635
3636 /*{{{ int flex_stat(char *fspec, struct mystat *statbufp)*/
3637 int
3638 flex_stat(char *fspec, struct mystat *statbufp)
3639 {
3640     char fileified[NAM$C_MAXRSS+1];
3641     int retval = -1;
3642
3643     if (statbufp == (struct mystat *) &statcache)
3644       do_tovmsspec(fspec,namecache,0);
3645     if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3646       memset(statbufp,0,sizeof *statbufp);
3647       statbufp->st_dev = encode_dev("_NLA0:");
3648       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3649       statbufp->st_uid = 0x00010001;
3650       statbufp->st_gid = 0x0001;
3651       time((time_t *)&statbufp->st_mtime);
3652       statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3653       return 0;
3654     }
3655
3656     /* Try for a directory name first.  If fspec contains a filename without
3657      * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir
3658      * and sea:[wine.dark]water. exist, we prefer the directory here.
3659      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
3660      * not sea:[wine.dark]., if the latter exists.  If the intended target is
3661      * the file with null type, specify this by calling flex_stat() with
3662      * a '.' at the end of fspec.
3663      */
3664     if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
3665       retval = stat(fileified,(stat_t *) statbufp);
3666       if (!retval && statbufp == (struct mystat *) &statcache)
3667         strcpy(namecache,fileified);
3668     }
3669     if (retval) retval = stat(fspec,(stat_t *) statbufp);
3670     if (!retval) {
3671       statbufp->st_dev = encode_dev(statbufp->st_devnam);
3672 #     ifdef VMSISH_TIME
3673       if (!VMSISH_TIME) { /* Return UTC instead of local time */
3674 #     else
3675       if (1) {
3676 #     endif
3677         if (!gmtime_emulation_type) (void)time(NULL);
3678         statbufp->st_mtime -= utc_offset_secs;
3679         statbufp->st_atime -= utc_offset_secs;
3680         statbufp->st_ctime -= utc_offset_secs;
3681       }
3682     }
3683     return retval;
3684
3685 }  /* end of flex_stat() */
3686 /*}}}*/
3687
3688 /* Insures that no carriage-control translation will be done on a file. */
3689 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3690 FILE *
3691 my_binmode(FILE *fp, char iotype)
3692 {
3693     char filespec[NAM$C_MAXRSS], *acmode;
3694     fpos_t pos;
3695
3696     if (!fgetname(fp,filespec)) return NULL;
3697     if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL;
3698     switch (iotype) {
3699       case '<': case 'r':           acmode = "rb";                      break;
3700       case '>': case 'w':
3701         /* use 'a' instead of 'w' to avoid creating new file;
3702            fsetpos below will take care of restoring file position */
3703       case 'a':                     acmode = "ab";                      break;
3704       case '+': case '|': case 's': acmode = "rb+";                     break;
3705       case '-':                     acmode = fileno(fp) ? "ab" : "rb";  break;
3706       default:
3707         warn("Unrecognized iotype %c in my_binmode",iotype);
3708         acmode = "rb+";
3709     }
3710     if (freopen(filespec,acmode,fp) == NULL) return NULL;
3711     if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL;
3712     return fp;
3713 }  /* end of my_binmode() */
3714 /*}}}*/
3715
3716
3717 /*{{{char *my_getlogin()*/
3718 /* VMS cuserid == Unix getlogin, except calling sequence */
3719 char *
3720 my_getlogin()
3721 {
3722     static char user[L_cuserid];
3723     return cuserid(user);
3724 }
3725 /*}}}*/
3726
3727
3728 /*  rmscopy - copy a file using VMS RMS routines
3729  *
3730  *  Copies contents and attributes of spec_in to spec_out, except owner
3731  *  and protection information.  Name and type of spec_in are used as
3732  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
3733  *  should try to propagate timestamps from the input file to the output file.
3734  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
3735  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
3736  *  propagated to the output file at creation iff the output file specification
3737  *  did not contain an explicit name or type, and the revision date is always
3738  *  updated at the end of the copy operation.  If it is greater than 0, then
3739  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3740  *  other than the revision date should be propagated, and bit 1 indicates
3741  *  that the revision date should be propagated.
3742  *
3743  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3744  *
3745  *  Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3746  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
3747  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
3748  * as part of the Perl standard distribution under the terms of the
3749  * GNU General Public License or the Perl Artistic License.  Copies
3750  * of each may be found in the Perl standard distribution.
3751  */
3752 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3753 int
3754 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3755 {
3756     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3757          rsa[NAM$C_MAXRSS], ubf[32256];
3758     unsigned long int i, sts, sts2;
3759     struct FAB fab_in, fab_out;
3760     struct RAB rab_in, rab_out;
3761     struct NAM nam;
3762     struct XABDAT xabdat;
3763     struct XABFHC xabfhc;
3764     struct XABRDT xabrdt;
3765     struct XABSUM xabsum;
3766
3767     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
3768         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3769       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3770       return 0;
3771     }
3772
3773     fab_in = cc$rms_fab;
3774     fab_in.fab$l_fna = vmsin;
3775     fab_in.fab$b_fns = strlen(vmsin);
3776     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3777     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3778     fab_in.fab$l_fop = FAB$M_SQO;
3779     fab_in.fab$l_nam =  &nam;
3780     fab_in.fab$l_xab = (void *) &xabdat;
3781
3782     nam = cc$rms_nam;
3783     nam.nam$l_rsa = rsa;
3784     nam.nam$b_rss = sizeof(rsa);
3785     nam.nam$l_esa = esa;
3786     nam.nam$b_ess = sizeof (esa);
3787     nam.nam$b_esl = nam.nam$b_rsl = 0;
3788
3789     xabdat = cc$rms_xabdat;        /* To get creation date */
3790     xabdat.xab$l_nxt = (void *) &xabfhc;
3791
3792     xabfhc = cc$rms_xabfhc;        /* To get record length */
3793     xabfhc.xab$l_nxt = (void *) &xabsum;
3794
3795     xabsum = cc$rms_xabsum;        /* To get key and area information */
3796
3797     if (!((sts = sys$open(&fab_in)) & 1)) {
3798       set_vaxc_errno(sts);
3799       switch (sts) {
3800         case RMS$_FNF:
3801         case RMS$_DIR:
3802           set_errno(ENOENT); break;
3803         case RMS$_DEV:
3804           set_errno(ENODEV); break;
3805         case RMS$_SYN:
3806           set_errno(EINVAL); break;
3807         case RMS$_PRV:
3808           set_errno(EACCES); break;
3809         default:
3810           set_errno(EVMSERR);
3811       }
3812       return 0;
3813     }
3814
3815     fab_out = fab_in;
3816     fab_out.fab$w_ifi = 0;
3817     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3818     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3819     fab_out.fab$l_fop = FAB$M_SQO;
3820     fab_out.fab$l_fna = vmsout;
3821     fab_out.fab$b_fns = strlen(vmsout);
3822     fab_out.fab$l_dna = nam.nam$l_name;
3823     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3824
3825     if (preserve_dates == 0) {  /* Act like DCL COPY */
3826       nam.nam$b_nop = NAM$M_SYNCHK;
3827       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
3828       if (!((sts = sys$parse(&fab_out)) & 1)) {
3829         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3830         set_vaxc_errno(sts);
3831         return 0;
3832       }
3833       fab_out.fab$l_xab = (void *) &xabdat;
3834       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3835     }
3836     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
3837     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
3838       preserve_dates =0;      /* bitmask from this point forward   */
3839
3840     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3841     if (!((sts = sys$create(&fab_out)) & 1)) {
3842       set_vaxc_errno(sts);
3843       switch (sts) {
3844         case RMS$_DIR:
3845           set_errno(ENOENT); break;
3846         case RMS$_DEV:
3847           set_errno(ENODEV); break;
3848         case RMS$_SYN:
3849           set_errno(EINVAL); break;
3850         case RMS$_PRV:
3851           set_errno(EACCES); break;
3852         default:
3853           set_errno(EVMSERR);
3854       }
3855       return 0;
3856     }
3857     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
3858     if (preserve_dates & 2) {
3859       /* sys$close() will process xabrdt, not xabdat */
3860       xabrdt = cc$rms_xabrdt;
3861 #ifndef __GNUC__
3862       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3863 #else
3864       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
3865        * is unsigned long[2], while DECC & VAXC use a struct */
3866       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
3867 #endif
3868       fab_out.fab$l_xab = (void *) &xabrdt;
3869     }
3870
3871     rab_in = cc$rms_rab;
3872     rab_in.rab$l_fab = &fab_in;
3873     rab_in.rab$l_rop = RAB$M_BIO;
3874     rab_in.rab$l_ubf = ubf;
3875     rab_in.rab$w_usz = sizeof ubf;
3876     if (!((sts = sys$connect(&rab_in)) & 1)) {
3877       sys$close(&fab_in); sys$close(&fab_out);
3878       set_errno(EVMSERR); set_vaxc_errno(sts);
3879       return 0;
3880     }
3881
3882     rab_out = cc$rms_rab;
3883     rab_out.rab$l_fab = &fab_out;
3884     rab_out.rab$l_rbf = ubf;
3885     if (!((sts = sys$connect(&rab_out)) & 1)) {
3886       sys$close(&fab_in); sys$close(&fab_out);
3887       set_errno(EVMSERR); set_vaxc_errno(sts);
3888       return 0;
3889     }
3890
3891     while ((sts = sys$read(&rab_in))) {  /* always true  */
3892       if (sts == RMS$_EOF) break;
3893       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3894       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3895         sys$close(&fab_in); sys$close(&fab_out);
3896         set_errno(EVMSERR); set_vaxc_errno(sts);
3897         return 0;
3898       }
3899     }
3900
3901     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
3902     sys$close(&fab_in);  sys$close(&fab_out);
3903     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3904     if (!(sts & 1)) {
3905       set_errno(EVMSERR); set_vaxc_errno(sts);
3906       return 0;
3907     }
3908
3909     return 1;
3910
3911 }  /* end of rmscopy() */
3912 /*}}}*/
3913
3914
3915 /***  The following glue provides 'hooks' to make some of the routines
3916  * from this file available from Perl.  These routines are sufficiently
3917  * basic, and are required sufficiently early in the build process,
3918  * that's it's nice to have them available to miniperl as well as the
3919  * full Perl, so they're set up here instead of in an extension.  The
3920  * Perl code which handles importation of these names into a given
3921  * package lives in [.VMS]Filespec.pm in @INC.
3922  */
3923
3924 void
3925 rmsexpand_fromperl(CV *cv)
3926 {
3927   dXSARGS;
3928   char *fspec, *defspec = NULL, *rslt;
3929
3930   if (!items || items > 2)
3931     croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
3932   fspec = SvPV(ST(0),na);
3933   if (!fspec || !*fspec) XSRETURN_UNDEF;
3934   if (items == 2) defspec = SvPV(ST(1),na);
3935
3936   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
3937   ST(0) = sv_newmortal();
3938   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
3939   XSRETURN(1);
3940 }
3941
3942 void
3943 vmsify_fromperl(CV *cv)
3944 {
3945   dXSARGS;
3946   char *vmsified;
3947
3948   if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3949   vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3950   ST(0) = sv_newmortal();
3951   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3952   XSRETURN(1);
3953 }
3954
3955 void
3956 unixify_fromperl(CV *cv)
3957 {
3958   dXSARGS;
3959   char *unixified;
3960
3961   if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3962   unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3963   ST(0) = sv_newmortal();
3964   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3965   XSRETURN(1);
3966 }
3967
3968 void
3969 fileify_fromperl(CV *cv)
3970 {
3971   dXSARGS;
3972   char *fileified;
3973
3974   if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3975   fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3976   ST(0) = sv_newmortal();
3977   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3978   XSRETURN(1);
3979 }
3980
3981 void
3982 pathify_fromperl(CV *cv)
3983 {
3984   dXSARGS;
3985   char *pathified;
3986
3987   if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3988   pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3989   ST(0) = sv_newmortal();
3990   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3991   XSRETURN(1);
3992 }
3993
3994 void
3995 vmspath_fromperl(CV *cv)
3996 {
3997   dXSARGS;
3998   char *vmspath;
3999
4000   if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4001   vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
4002   ST(0) = sv_newmortal();
4003   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4004   XSRETURN(1);
4005 }
4006
4007 void
4008 unixpath_fromperl(CV *cv)
4009 {
4010   dXSARGS;
4011   char *unixpath;
4012
4013   if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4014   unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
4015   ST(0) = sv_newmortal();
4016   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4017   XSRETURN(1);
4018 }
4019
4020 void
4021 candelete_fromperl(CV *cv)
4022 {
4023   dXSARGS;
4024   char fspec[NAM$C_MAXRSS+1], *fsp;
4025   SV *mysv;
4026   IO *io;
4027
4028   if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4029
4030   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4031   if (SvTYPE(mysv) == SVt_PVGV) {
4032     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
4033       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4034       ST(0) = &sv_no;
4035       XSRETURN(1);
4036     }
4037     fsp = fspec;
4038   }
4039   else {
4040     if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
4041       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4042       ST(0) = &sv_no;
4043       XSRETURN(1);
4044     }
4045   }
4046
4047   ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
4048   XSRETURN(1);
4049 }
4050
4051 void
4052 rmscopy_fromperl(CV *cv)
4053 {
4054   dXSARGS;
4055   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4056   int date_flag;
4057   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4058                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4059   unsigned long int sts;
4060   SV *mysv;
4061   IO *io;
4062
4063   if (items < 2 || items > 3)
4064     croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4065
4066   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4067   if (SvTYPE(mysv) == SVt_PVGV) {
4068     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
4069       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4070       ST(0) = &sv_no;
4071       XSRETURN(1);
4072     }
4073     inp = inspec;
4074   }
4075   else {
4076     if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
4077       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4078       ST(0) = &sv_no;
4079       XSRETURN(1);
4080     }
4081   }
4082   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4083   if (SvTYPE(mysv) == SVt_PVGV) {
4084     if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
4085       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4086       ST(0) = &sv_no;
4087       XSRETURN(1);
4088     }
4089     outp = outspec;
4090   }
4091   else {
4092     if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
4093       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4094       ST(0) = &sv_no;
4095       XSRETURN(1);
4096     }
4097   }
4098   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4099
4100   ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no;
4101   XSRETURN(1);
4102 }
4103
4104 void
4105 init_os_extras()
4106 {
4107   char* file = __FILE__;
4108
4109   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4110   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4111   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4112   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4113   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4114   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4115   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4116   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4117   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
4118   return;
4119 }
4120
4121 /*  End of vms.c */