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