vms/vms.c

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