vms/vms.c

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