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