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