vms/vms.c

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