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