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