vms/vms.c

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