/* 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 <sys/param.h> /* For gethostname() */

#include <netdb.h>
/* This lossage brought to you by Solaris and BIND */
/* We thank Solaris for forcing users to get a new BIND */
/* We thank BIND for blowing away the Solaris includea for MAXHOSTNAMELEN */
#ifndef MAXHOSTNAMELEN		
#include <arpa/nameser.h>
#ifndef MAXHOSTNAMELEN		
#define MAXHOSTNAMELEN      MAXDNAME
#endif
#endif

#include <pwd.h>
#include <errno.h>
#include <sys/wait.h>
#include <unistd.h>
#include <string.h>
#include <utime.h>
#ifdef HAVE_CRYPT_H
#include <crypt.h> 
#endif
#include "cstuff.h"
#include "machine/stdio_dep.h"

/* Make sure our exports match up w/the implementation: */
#include "syscalls1.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] */

s48_value wait_pid(s48_value s48_pid, s48_value s48_flags)
{
  int status=0;
  pid_t pid = (pid_t) s48_extract_integer (s48_pid); 
  int flags = s48_extract_integer (s48_flags); 
  pid_t result_pid;

  result_pid = waitpid(pid, &status, flags);
  return s48_cons ((result_pid == -1) ? s48_enter_fixnum(errno) : S48_FALSE, 
		   s48_cons (s48_enter_integer (result_pid),
			     s48_cons (s48_enter_integer (status),
				       S48_NULL)));
}


/* 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.
*/

s48_value scheme_exec(s48_value prog, s48_value argv, s48_value env)
{
  int i, j, e;
  int argc = S48_VECTOR_LENGTH(argv);

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

  if( unix_argv == NULL ) s48_raise_os_error_3(errno, prog, argv, env);

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

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

    if( !unix_env ){
      Free(unix_argv);
      s48_raise_os_error_3(errno, prog, argv, env);
    }

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

  execve(s48_extract_string (prog), unix_argv, unix_env); /* Do it. */
  e = errno;
  if( env != S48_TRUE ) {
    Free(unix_env);
  }
  Free(unix_argv);
  return s48_enter_fixnum(e); // Don't raise an exception since
                              // we're maybe just testing the path
}

s48_value scsh_exit(s48_value status)
{
    exit(s48_extract_fixnum(status));
    return S48_FALSE;
}

s48_value scsh__exit(s48_value status)
{
    _exit(s48_extract_fixnum(status));
    return S48_FALSE;
}

s48_value scsh_fork()
{
  pid_t pid = fork();
  if (pid == -1)
    s48_raise_os_error(errno);
  else return s48_enter_fixnum (pid);
}

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

/* Returns (r w) */
s48_value scheme_pipe()
{
  int fds[2];
  if(pipe(fds) == -1) 
    s48_raise_os_error(errno);
  else
    return s48_cons (s48_enter_fixnum (fds[0]),
		     s48_cons (s48_enter_fixnum (fds [1]),
			       S48_NULL));
}

s48_value scsh_kill (s48_value pid, s48_value signal)
{
  int ret = kill ((pid_t) s48_extract_fixnum (pid),
		  s48_extract_fixnum (signal));
  if (ret == -1)
    s48_raise_os_error_2(errno, pid, signal);
  else return s48_enter_fixnum (ret);
}
  

/* Read the symlink. */

s48_value scm_readlink(s48_value path)
{
  char linkpath[MAXPATHLEN+1];
  int retval = readlink(s48_extract_string (path), linkpath, MAXPATHLEN);
  if (retval == -1)
    s48_raise_os_error_1(errno, path);
  else
    {
      linkpath[retval] = '\0';
      return s48_enter_string(linkpath);
    }
}


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

int scm_utime(char const *path, time_t ac, time_t mod)
{
    struct utimbuf t;
    t.actime = ac;
    t.modtime = mod;
    return utime(path, &t);
}

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


s48_value set_cloexec(s48_value _fd, s48_value _val)
{
  int fd = s48_extract_fixnum (_fd);
  int val = (_val == S48_TRUE) ? 1 : 0;
  int flags = fcntl(fd, F_GETFD);
  if( flags == -1 ) s48_raise_os_error_2(errno, _fd, _val);
  val = -val;	/* 0 -> 0 and 1 -> -1 */

  /* If it's already what we want, just return. */
  if( (flags & FD_CLOEXEC) == (FD_CLOEXEC & val) ) return S48_FALSE;

  flags = (flags & ~FD_CLOEXEC) | (val & FD_CLOEXEC);
  if (fcntl(fd, F_SETFD, flags) == -1)
    s48_raise_os_error_2(errno, _fd, _val);
  else return S48_FALSE;
}

s48_value scsh_chdir(s48_value directory){
  int retval = chdir (s48_extract_string (directory));
  if (retval == -1)
    s48_raise_os_error_1(errno, directory);
  return S48_TRUE;
}

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

/* Posix rules: If PATH_MAX is defined, it's the length of longest path.
** Otherwise, _POSIX_PATH_MAX = 255, and is a lower bound on said length.
** I'm writing out 255 as a literal because HP-UX isn't finding 
** _POSIX_PATH_MAX.
*/
#ifdef PATH_MAX
#define scsh_path_max (PATH_MAX)
#else
#define scsh_path_max (255)
#endif

/* Simple-minded POSIX version. */
s48_value scheme_cwd()
{
  char *buf;
  int size = scsh_path_max + 1; /* +1 for terminating nul byte... */

  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;
    }

  return s48_enter_string(buf);		/* win */

 lose:
  {int e = errno;
   Free(buf);
   s48_raise_os_error(e);}
}

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

/* Sleazing on the types here -- the ret values should be clock_t, not int,
** but cig can't handle it.
*/

int 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;
    }

int 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. */
s48_value read_fdes_char(int fd)
{
  int i; char c;
  if( (i=read(fd, &c, 1)) < 0 ) return s48_enter_fixnum(errno);
  if(i==0) return S48_FALSE;
  return s48_enter_char(c);
}

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


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

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



/* 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: */
s48_value really_stat(struct stat *s, s48_value vec)
{
  int modes, typecode = -1;
  S48_DECLARE_GC_PROTECT(1);
 
  S48_GC_PROTECT_1(vec);
 
  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;
  
  S48_VECTOR_SET(vec,0,s48_enter_fixnum(typecode));
  S48_VECTOR_SET(vec,1, s48_enter_integer(s->st_dev));
  S48_VECTOR_SET(vec,2, s48_enter_integer(s->st_ino));
  S48_VECTOR_SET(vec,3, s48_enter_integer(s->st_mode));
  S48_VECTOR_SET(vec,4, s48_enter_integer(s->st_nlink));
  S48_VECTOR_SET(vec,5, s48_enter_integer(s->st_uid));
  S48_VECTOR_SET(vec,6, s48_enter_integer(s->st_gid));
  S48_VECTOR_SET(vec,7, s48_enter_integer(s->st_size));
  S48_VECTOR_SET(vec,8, s48_enter_integer(s->st_atime));
  S48_VECTOR_SET(vec,9, s48_enter_integer(s->st_mtime));
  S48_VECTOR_SET(vec,10, s48_enter_integer(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. */
  S48_GC_UNPROTECT();
  return S48_UNSPECIFIC;
}

s48_value scheme_stat(s48_value path, s48_value vec, s48_value chase_p)
{
  struct stat s;
  const char * cp_path = s48_extract_string(path);
  int retval = (chase_p != S48_FALSE) ? stat(cp_path, &s) : lstat(cp_path, &s);

  if (retval == -1) s48_raise_os_error_2 (errno, path, chase_p);

  return really_stat (&s, vec);
}

s48_value scheme_fstat(s48_value fd, s48_value vec)
{
  struct stat s;
  int retval = fstat (s48_extract_fixnum (fd), &s);
  if (retval == -1) s48_raise_os_error_1 (errno, fd);
  return really_stat (&s, vec);
}


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

s48_value scsh_getgid()
{
  return s48_enter_integer(getgid());
}

s48_value scsh_getegid()
{
  return s48_enter_integer(getegid());
}

s48_value scsh_setgid(s48_value gid)
{
  int retval = setgid (s48_extract_integer (gid));
  if (retval == -1)
    s48_raise_os_error_1(errno, gid);
  return S48_UNSPECIFIC;
}

s48_value scsh_setegid(s48_value gid)
{
  int retval = setegid (s48_extract_integer (gid));
  if (retval == -1)
    s48_raise_os_error_1(errno, gid);
  return S48_UNSPECIFIC;
}

/* Load the supplementary groups into a list */

s48_value get_groups()
{
  int retval;
  int veclen = getgroups(0,NULL);
  int i = veclen;
  s48_value l = S48_NULL;
  gid_t gvec0[20], *gp = gvec0;

  if( veclen > 20 )
    if (NULL == (gp=Malloc(gid_t,veclen))) s48_raise_os_error(errno);

  retval = getgroups(veclen, gp);

  if (retval == -1){
    if (veclen > 20) Free(gp);
    s48_raise_os_error(errno);
  }
  else if (retval != veclen){     // paranoia...
    get_groups();
  }
  else{
    while (i > 0){
      l = s48_cons(s48_enter_integer(gp[--i]), l);
    }
    
    if (veclen > 20) Free(gp);
    
    return l;
  }
}
s48_value scsh_getuid()
{
  return s48_enter_integer(getuid());
}

s48_value scsh_geteuid()
{
  return s48_enter_integer(geteuid());
}

s48_value scsh_setuid(s48_value uid)
{
  int retval = setuid (s48_extract_integer (uid));
  if (retval == -1)
    s48_raise_os_error_1(errno, uid);
  return S48_UNSPECIFIC;
}

s48_value scsh_seteuid(s48_value uid)
{
  int retval = seteuid (s48_extract_integer (uid));
  if (retval == -1)
    s48_raise_os_error_1(errno, uid);
  return S48_UNSPECIFIC;
}
    
/* Environment hackery
*******************************************************************************
*/
static s48_value envvec_record_type_binding = S48_FALSE;
static s48_value add_envvec_finalizerB_binding = S48_FALSE;

#define ENVVEC_ENVIRON(envvec) \
  ((char**) s48_extract_integer(S48_RECORD_REF((envvec),0)))

/* The envvec corresponding to the current environment.
** Null if the current environment has no corresponding envvec struct
** (which should only be true of the initial environment at process
** startup time.) That is,
**     !current_env || current_env->env == environ
*/
s48_value current_env = S48_FALSE;

s48_value align_env(s48_value envvec)
  { 
    environ = ENVVEC_ENVIRON(envvec);
    current_env = envvec;     
    return S48_TRUE;
}

char** original_environ = 0;

s48_value free_envvec (s48_value envvec)
{
  char** env = ENVVEC_ENVIRON(envvec);
  int i=0;
  if (env == original_environ)
    {
      return S48_FALSE;
    }
  while (env[i] != 0){
    Free(env[i]);
    i++;
  }
  Free(env);
  return S48_TRUE;
}

s48_value make_envvec(char** newenv){
  s48_value thread_env;

  thread_env = s48_make_record(envvec_record_type_binding);
  
  S48_RECORD_SET(thread_env, 0, s48_enter_integer((long)newenv));
  s48_call_scheme(S48_SHARED_BINDING_REF(add_envvec_finalizerB_binding),
		  1,
		  thread_env);
  return thread_env;
}

s48_value scm_envvec(){
  s48_value thread_env;
  if (current_env == 0){
    thread_env = make_envvec(environ);
    current_env = thread_env;
  }
  else thread_env = current_env;

  if (original_environ == 0)
    original_environ = environ;

  return s48_cons (char_pp_2_string_list(environ), 
		   thread_env);
}

    
/* Load the (Scheme) strings in the (Scheme) vector VEC into environ.
*/

s48_value create_env(s48_value vec)
{
  int i, envsize;
  char **newenv;
  s48_value thread_env;
  S48_DECLARE_GC_PROTECT(1);
  S48_GC_PROTECT_1(vec);
 
  envsize = S48_VECTOR_LENGTH(vec);
    
  newenv = Malloc(char*, envsize+1);
  if( !newenv ) s48_raise_out_of_memory_error();
  
  
  for( i=0; i<envsize; i++ ) {
    char *s = scheme2c_strcpy(S48_VECTOR_REF(vec,i));
    if (!s) {
      /* Return all the memory and bail out. */
      while(--i) Free(newenv[i]);
      Free(newenv);
      Free(thread_env);
      s48_raise_out_of_memory_error();
    }
    newenv[i] = s;
  }

  newenv[envsize] = NULL;

  thread_env = make_envvec(newenv);
  environ = newenv;
  current_env = thread_env;

  S48_GC_UNPROTECT();
  return thread_env;
  
}
  
/*****************************************************************************/

/* N.B.: May be unaligned. */

s48_value scm_gethostname(void)
{
   char hostname[MAXHOSTNAMELEN+1]; 
    /* different OS's declare differently, so punt the prototype. */
    int gethostname(); 
    int retval = gethostname(hostname, MAXHOSTNAMELEN);
    if (retval == -1) s48_raise_os_error(errno);
    return s48_enter_string(hostname);
}

#include <errno.h>

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

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

s48_value fcntl_read(s48_value fd, s48_value command)
{ 
  int ret = fcntl(s48_extract_fixnum (fd), 
				 s48_extract_integer (command)); 
  if (ret == -1)
    s48_raise_os_error_2(errno, fd, command);
  else return s48_enter_fixnum (ret); 
}


s48_value fcntl_write(s48_value fd, s48_value command, s48_value value)
{ 
  int ret = fcntl(s48_extract_fixnum (fd), 
		  s48_extract_integer (command), 
		  s48_extract_integer (value));
  if (ret == -1)
    s48_raise_os_error_3(errno, fd, command, value);
  else return s48_enter_fixnum (ret); 
}

/* crypt()
******************
*/
s48_value scm_crypt(s48_value key, s48_value salt)
{
  char * ret = crypt (s48_extract_string (key), 
		      s48_extract_string(salt));

  // FreeBSD does this on error:
  if (ret == NULL) return s48_enter_string("");

  return s48_enter_string (ret);
}

void s48_init_syscalls2(){
  S48_GC_PROTECT_GLOBAL(envvec_record_type_binding);
  S48_GC_PROTECT_GLOBAL(add_envvec_finalizerB_binding);
  S48_GC_PROTECT_GLOBAL(current_env);
  envvec_record_type_binding = s48_get_imported_binding("envvec-record-type");
  add_envvec_finalizerB_binding = 
    s48_get_imported_binding("add-envvec-finalizer!");
}