vms/vms.c

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