scsh-0.6/scsh/syscalls1.c

532 lines
12 KiB
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 <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>
#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(int pid, int flags, int *result_pid, int *status)
{
*result_pid = waitpid(pid, status, flags);
return (*result_pid == -1) ? s48_enter_fixnum(errno) : S48_FALSE;
}
/* 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(const char *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 ) return errno;
/* Scheme->Unix convert the argv parameter. */
for(i=0; i<argc; i++)
unix_argv[i] = cig_string_body(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 ) goto lose;
for(j=0; j<envlen; j++)
unix_env[j] = cig_string_body(S48_VECTOR_REF(env,j));
unix_env[envlen] = NULL;
}
execve(prog, unix_argv, unix_env); /* Do it. */
if( env != S48_TRUE ) {
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 const *scm_readlink(const char *path)
{
int retval = readlink(path, linkpath, MAXPATHLEN);
return (char const *)
((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);}
int set_cloexec(int fd, int val)
{
int flags = fcntl(fd, F_GETFD);
if( flags == -1 ) return errno;
val = -val; /* 0 -> 0 and 1 -> -1 */
/* If it's already what we want, just return. */
if( (flags & FD_CLOEXEC) == (FD_CLOEXEC & val) ) return 0;
flags = (flags & ~FD_CLOEXEC) | (val & FD_CLOEXEC);
return fcntl(fd, F_SETFD, flags) ? errno : 0;
}
/* 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. */
int scheme_cwd(const char **dirp)
{
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;
}
*dirp = (const char*) buf; /* win */
return 0;
lose:
{int e = errno;
Free(buf);
*dirp = 0;
return e;}
}
#if 0
/* Faster SUNOS version. */
/* We have to use malloc, because the stub is going to free the string. */
int scheme_cwd(const char **dirp)
{
char *buf = Malloc(char,MAXPATHLEN);
int e;
if( buf && getwd(buf) ) {
*dirp = (const char*) buf;
return 0;
}
/* lose */
e = errno;
Free(buf);
*dirp = 0;
return e;
}
#endif
/* 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(int *utime, int *stime, int *cutime, int *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);}
int read_fdes_substring(s48_value buf, int start, int end, int fd)
{
return read(fd, StrByte(buf,start), end-start);
}
int write_fdes_substring(s48_value buf, int start, int end, int fd)
{
return write(fd, StrByte(buf,start), end-start);
}
/*
** 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, s48_value vec)
{
int modes, typecode = -1;
if( 14 != S48_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;
S48_VECTOR_SET(vec,0,s48_enter_fixnum(typecode));
S48_VECTOR_SET(vec,1, s48_enter_fixnum(s->st_dev));
S48_VECTOR_SET(vec,2, s48_enter_fixnum(s->st_ino));
S48_VECTOR_SET(vec,3, s48_enter_fixnum(s->st_mode));
S48_VECTOR_SET(vec,4, s48_enter_fixnum(s->st_nlink));
S48_VECTOR_SET(vec,5, s48_enter_fixnum(s->st_uid));
S48_VECTOR_SET(vec,6, s48_enter_fixnum(s->st_gid));
S48_VECTOR_SET(vec,7, s48_enter_fixnum(s->st_size));
S48_VECTOR_SET(vec,8, s48_enter_fixnum( low24(s->st_atime)));
S48_VECTOR_SET(vec,9, s48_enter_fixnum(hi_but24(s->st_atime)));
S48_VECTOR_SET(vec,10, s48_enter_fixnum( low24(s->st_mtime)));
S48_VECTOR_SET(vec,11, s48_enter_fixnum(hi_but24(s->st_mtime)));
S48_VECTOR_SET(vec,12, s48_enter_fixnum( low24(s->st_ctime)));
S48_VECTOR_SET(vec,13, s48_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(const char *path, s48_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, s48_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(s48_value gvec)
{
int veclen = S48_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--; )
S48_VECTOR_SET(gvec,i, s48_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 s48_enter_fixnum(errno);
strcpy(s1, s);
return putenv(s1) ? s48_enter_fixnum(errno) : S48_FALSE;
}
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(s48_value vec)
{
int i, envsize;
char **newenv;
envsize = S48_VECTOR_LENGTH(vec);
newenv = Malloc(char*, envsize+1);
if( !newenv ) return errno;
for( i=0; i<envsize; i++ ) {
char *s = scheme2c_strcpy(S48_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(const 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];
char *scm_gethostname(void)
{
/* different OS's declare differently, so punt the prototype. */
int gethostname();
gethostname(hostname, MAXHOSTNAMELEN);
return 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()
******************
*/
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); }