scsh-0.5/scsh/syscalls1.c

/* Scheme48/scsh Unix system interface.
** Routines that require custom C support.
** Copyright (c) 1993,1994 by Olin Shivers.
*/

#include "sysdep.h"
#include <stdio.h>
#include <stdlib.h>
#include <sys/signal.h>
#include <sys/types.h>
#include <sys/times.h>
#include <sys/time.h>
#include <fcntl.h>		/* for O_RDWR */
#include <sys/stat.h>
#include <netdb.h>
#include <pwd.h>
#include <sys/param.h> /* For gethostname() */
#include <errno.h>
#include <sys/wait.h>
#include <unistd.h>
#include <string.h>
#include <utime.h>

#include "cstuff.h"

extern int errno;
extern char **environ;

/* Sux because it's dependent on 32-bitness. */
#define hi8(i)  (((i)>>24) & 0xff)
#define lo24(i) ((i) & 0xffffff)
#define comp8_24(hi, lo) (((hi)<<24) + (lo))


/* Process stuff
*******************************************************************************
** wait, exec
*/

/* Args: pid, flags; returns [retval, status] */

scheme_value wait_pid(int pid, int flags, int *result_pid, int *status)
{
    *result_pid = waitpid(pid, status, flags);
    return (*result_pid == -1) ? ENTER_FIXNUM(errno) : SCHFALSE;
    }


/* env:  Scheme vector of Scheme strings, e.g., #("TERM=vt100" ...) or #T.
** argv: Scheme vector of Scheme strings.
** prog: String.
** 
** We don't typecheck the args. You must do the typechecking
** on the Scheme side.
*/

int scheme_exec(char *prog, scheme_value argv, scheme_value env)
{
  int i, j, e;
  int argc = VECTOR_LENGTH(argv);

  char **unix_argv = Malloc(char*, argc+1);
  char **unix_env;

  if( unix_argv == NULL ) return errno;

  /* Scheme->Unix convert the argv parameter. */
  for(i=0; i<argc; i++)
    unix_argv[i] = cig_string_body(VECTOR_REF(argv,i));
  unix_argv[argc] = NULL;

  /* Scheme->Unix convert the env parameter. */
  if( env == SCHTRUE ) unix_env = environ;
  else {
    int envlen = VECTOR_LENGTH(env);
    unix_env = Malloc(char*, envlen+1);

    if( !unix_env ) goto lose;

    for(j=0; j<envlen; j++)
      unix_env[j] = cig_string_body(VECTOR_REF(env,j));
    unix_env[envlen] = NULL;
  }

  execve(prog, unix_argv, unix_env); /* Do it. */

  if( env != SCHTRUE ) {
    e = errno;
    Free(unix_env);
    errno = e;
  }
 lose:
  e = errno;
  Free(unix_argv);
  return e;
}


/* Random file and I/O stuff
*******************************************************************************
*/

/* Returns [errno, r, w] */
int scheme_pipe(int *r, int *w)
{
  int fds[2];
  if( pipe(fds) ) {
    *r = 0; *w = 0;
    return errno;
  }

  *r = fds[0]; *w = fds[1];
  return 0;
}


/* Read the symlink into static memory. Return NULL on error. */

static char linkpath[MAXPATHLEN+1]; /*  Maybe unaligned. Not reentrant. */

char *scm_readlink(char *path)
{
  int retval = readlink(path, linkpath, MAXPATHLEN);

  return (retval == -1)
    ?  NULL
      :  ( linkpath[retval] = '\0', linkpath );
}



/* Scheme interfaces to utime(). 
** Complicated by need to pass real 32-bit quantities.
*/

int scm_utime(char const *path, int ac_hi, int ac_lo, int mod_hi, int mod_lo)
{
    struct utimbuf t;
    t.actime = comp8_24(ac_hi, ac_lo);
    t.modtime = comp8_24(mod_hi, mod_lo);
    return utime(path, &t);
    }

int scm_utime_now(char const *path) {return utime(path, 0);}


/* Two versions of CWD
*******************************************************************************
*/

/* Simple-minded POSIX version. */
int scheme_cwd(char **dirp)
{
  char *buf;
  int size = 100;

  buf = Malloc(char,size);
  if(!buf) goto lose;

  while( !getcwd(buf, size) )
    if( errno != ERANGE ) goto lose;
    else {
      /* Double the buf and retry. */
      char *nbuf = Realloc(char, buf, size += size);
      if( !nbuf ) goto lose;
      buf = nbuf;
    }

  *dirp = buf;			/* win */
  return 0;

 lose:
  {int e = errno;
   Free(buf);
   *dirp = NULL;
   return e;}
}


#if 0
/* Faster SUNOS version. */
/* We have to use malloc, because the stub is going to free the string. */

int scheme_cwd(char **dirp)
{
  char *buf = Malloc(char,MAXPATHLEN); 
  int e;

  if( buf && getwd(buf) ) {
    *dirp = buf;
    return 0;
  }

  /* lose */
  e = errno;
  Free(buf);
  *dirp = NULL;
  return e;
}
#endif


/* Process times
*******************************************************************************
*/

long process_times(clock_t *utime, clock_t *stime,
		   clock_t *cutime, clock_t *cstime)
{
    struct tms tms;
    clock_t t = times(&tms);
    if (t == -1) return -1;
    *utime = tms.tms_utime;
    *stime = tms.tms_stime;
    *cutime = tms.tms_cutime;
    *cstime = tms.tms_cstime;
    return t;
    }

long cpu_clock_ticks_per_sec() 
{
#ifdef _SC_CLK_TCK
  static long clock_tick = 0;
    
  if (clock_tick == 0)
    clock_tick = sysconf(_SC_CLK_TCK); /* POSIX.1, POSIX.2 */
  return clock_tick;
#else
#ifdef CLK_TCK
  return CLK_TCK;
#else
  return 60;
#endif
#endif    
}

/* Reading and writing
*******************************************************************************
*/

/* Return a char, #f (EOF), or errno. */
scheme_value read_fdes_char(int fd)
{
  int i; char c;
  if( (i=read(fd, &c, 1)) < 0 ) return ENTER_FIXNUM(errno);
  if(i==0) return SCHFALSE;
  return ENTER_CHAR(c);
}

int write_fdes_char(char c, int fd)  {return write(fd, &c, 1);}


int read_fdes_substring(scheme_value buf, int start, int end, int fd)
{
  return read(fd, StrByte(buf,start), end-start);
}

#define Min(a,b) (((a) < (b)) ? (a) : (b))	/* Not a function. */

/* Warning -- This fun is not very portable, since we use _iobuf internals.
**
** Also, note the clearerr() call. This is so a ^D on a tty input stream
** doesn't shut the stream down forever. SunOS doesn't handle this according
** to POSIX spec, so we have to explicitly hack this case.
*/

int read_stream_substring(scheme_value buf, int start, int end, FILE *f)
{
  char *p = StrByte(buf,start);
  int len = end-start;

  clearerr(f);

  /* If there's data in the buffer, use it. */

  if (fbufcount(f) > 0)
    return fread(p, 1, Min(len, fbufcount(f)), f);

  /* Otherwise, do a read. */
  return read(fileno(f), p, len);
}


int write_fdes_substring(scheme_value buf, int start, int end, int fd)
{
  return write(fd, StrByte(buf,start), end-start);
}

/* We assume either fileno(f) does blocking i/o or f is unbuffered. */

int write_stream_substring(scheme_value buf, int start, int end, FILE *f)
{
  int retval = fwrite(StrByte(buf,start), 1, end-start, f);
  return ferror(f) ? -1 : retval; /* -1: error, 0: eof */
}


/*
** Stat hackery
*******************************************************************************
** DANGER, WILL ROBINSON: It's not necessarily true that all these 
** stat fields will fit into a fixnum.
** In fact, S48's 30 bit fixnums are almost certainly good enough
** for everything but times. 30 signed bits ran out in 1987.
** So the time fields are split, low 24, high everything else.
** I haven't bothered w/anything else, since the only other real limit
** is size -- files can't be bigger than .5Gb. 
*/

/* S_ISSOCK(mode) and S_ISLNK(mode) are not POSIX. You lose on a NeXT. Ugh. */
#ifndef S_ISSOCK
#define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK)
#endif
#ifndef S_ISLNK
#define S_ISLNK(mode) (((mode) & S_IFMT) == S_IFLNK)
#endif

#define low24(x) ((x) & 0xffffff)
#define hi_but24(x) (((x) >> 24) & 0xff)

/* Note that hi_but24 assumes value is a *32 bit* signed value. We have to
** do this, because C's right-shift operator exposes word width. A suckful
** language.
*/

/* Internal aux function -- loads stat values into Scheme vector: */
static int really_stat(int retval, struct stat *s, scheme_value vec)
{
  int modes, typecode = -1;

  if( 14 != VECTOR_LENGTH(vec) ) return -1;
  if( retval < 0 ) return errno;

  modes = s->st_mode;
  if( S_ISBLK(modes) )       typecode = 0;
  else if( S_ISCHR(modes) )  typecode = 1;
  else if( S_ISDIR(modes) )  typecode = 2;
  else if( S_ISFIFO(modes) ) typecode = 3;
  else if( S_ISREG(modes) )  typecode = 4;
  else if( S_ISSOCK(modes) ) typecode = 5;
  else if( S_ISLNK(modes) )  typecode = 6;
    
  VECTOR_REF(vec,0)  = ENTER_FIXNUM(typecode);
  VECTOR_REF(vec,1)  = ENTER_FIXNUM(s->st_dev);
  VECTOR_REF(vec,2)  = ENTER_FIXNUM(s->st_ino);
  VECTOR_REF(vec,3)  = ENTER_FIXNUM(s->st_mode);
  VECTOR_REF(vec,4)  = ENTER_FIXNUM(s->st_nlink);
  VECTOR_REF(vec,5)  = ENTER_FIXNUM(s->st_uid);
  VECTOR_REF(vec,6)  = ENTER_FIXNUM(s->st_gid);
  VECTOR_REF(vec,7)  = ENTER_FIXNUM(s->st_size);

  VECTOR_REF(vec,8)  = ENTER_FIXNUM(   low24(s->st_atime));
  VECTOR_REF(vec,9)  = ENTER_FIXNUM(hi_but24(s->st_atime));

  VECTOR_REF(vec,10) = ENTER_FIXNUM(   low24(s->st_mtime));
  VECTOR_REF(vec,11) = ENTER_FIXNUM(hi_but24(s->st_mtime));

  VECTOR_REF(vec,12) = ENTER_FIXNUM(   low24(s->st_ctime));
  VECTOR_REF(vec,13) = ENTER_FIXNUM(hi_but24(s->st_ctime));

  /* We also used to do st_rdev, st_blksize, and st_blocks.
     These aren't POSIX, and, e.g., are not around on SGI machines.
     Too bad -- blksize is useful. Unix sux. */

  return 0;
}

int scheme_stat(char *path, scheme_value vec, int chase_p)
{
  struct stat s;
  return really_stat(chase_p ? stat(path, &s) : lstat(path, &s), &s, vec);
}

int scheme_fstat(int fd, scheme_value vec)
{
  struct stat s;
  return really_stat(fstat(fd,&s), &s, vec);
}


/* Supplementary groups access
*******************************************************************************
*/

int num_supp_groups(void)
{
  return getgroups(0,NULL);
}

/* Load the supplementary groups into GVEC. */

int get_groups(scheme_value gvec)
{
  int veclen = VECTOR_LENGTH(gvec), i, retval;
  gid_t gvec0[20], *gp = gvec0;

  if( veclen > 20 )
    if( NULL == (gp=Malloc(gid_t,veclen)) ) return -1;

  retval = getgroups(veclen, gp);
    
  if( retval != -1 )
    for( i=veclen; i--; )
      VECTOR_REF(gvec,i) = ENTER_FIXNUM(gp[i]);

  if( veclen > 20 ) Free(gp);

  return retval;
}
    

/* Environment hackery
*******************************************************************************
*/

int put_env(const char *s)
{
  char *s1 = Malloc(char, strlen(s)+1);
  if( !s1 ) return ENTER_FIXNUM(errno);
    
  strcpy(s1, s);

  return putenv(s1) ? ENTER_FIXNUM(errno) : SCHFALSE;
}

char** scm_envvec(int *len)	/* Returns environ c-vector & its length. */
{
  char **ptr=environ;
  while( *ptr ) ptr++;
  *len = ptr-environ;

  return(environ);
}

/* Load the (Scheme) strings in the (Scheme) vector VEC into environ.
** Somewhat wasteful of memory: we do not free any of the memory
** in the old environ -- don't know if it is being shared elsewhere.
*/

int install_env(scheme_value vec)
{
  int i, envsize;
  char **newenv;

  envsize = VECTOR_LENGTH(vec);
  newenv = Malloc(char*, envsize+1);
  if( !newenv ) return errno;

  for( i=0; i<envsize; i++ ) {
    char *s = scheme2c_strcpy(VECTOR_REF(vec,i));
    if (!s) {
      /* Return all the memory and bail out. */
      int e = errno;
      while(--i) Free(newenv[i]);
      Free(newenv);
      return e;
    }
    newenv[i] = s;
  }

  newenv[i] = NULL;
  environ = newenv;
  return 0;
}


/* Delete the env var. */
void delete_env(char *var)
{
  int varlen = strlen(var);
  char **ptr = environ-1;

  do if( !*++ptr ) return;
  while( strncmp(*ptr, var, varlen) || (*ptr)[varlen] != '=' );

  do ptr[0] = ptr[1]; while( *++ptr ); 
}	


/*****************************************************************************/

/* N.B.: May be unaligned. 
** Not re-entrant, either -- will puke if multithreaded.
*/
static char hostname[MAXHOSTNAMELEN+1]; 

scheme_value scm_gethostname(void)
{
  /* different OS's declare differently, so punt the prototype. */
  int gethostname(); 
  gethostname(hostname, MAXHOSTNAMELEN);
  return (scheme_value) hostname;
}

#include <errno.h>

const char *errno_msg(int i)
{
  /* temp hack until we figure out what to do about losing sys_errlist's */
#ifdef HAVE_CONST_SYS_ERRLIST
  const
#endif
    extern char *sys_errlist[]; 
  extern int sys_nerr;
  return ( i < 0 || i > sys_nerr )
    ? (char*) NULL		/* i.e., #f */
      : sys_errlist[i];
}

/* Some of fcntl()
******************
*/

int fcntl_read(int fd, int command)
{ return fcntl(fd, command); }


int fcntl_write(int fd, int command, int value)
{ return fcntl(fd, command, value); }