Ported some functions to new FFI.
This commit is contained in:
parent
66cb77856d
commit
c7be5ed2b1
|
@ -82,15 +82,10 @@
|
|||
|
||||
;;; Process
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-foreign %%exec/errno
|
||||
(scheme_exec (string prog)
|
||||
(vector-desc argv)
|
||||
(desc env)) ; string vector or #t.
|
||||
fixnum)
|
||||
|
||||
;; we can't algin env here, because exec-path/env calls
|
||||
;; %%exec/errno directly F*&% *P
|
||||
(define-stubless-foreign %%exec/errno (prog argv env) "scheme_exec")
|
||||
|
||||
(define (%%exec prog argv env)
|
||||
(errno-error (%%exec/errno prog argv env) %exec prog argv env)) ; cute.
|
||||
|
||||
|
@ -126,11 +121,7 @@
|
|||
|
||||
;;; Working directory
|
||||
|
||||
(define-foreign %chdir/errno
|
||||
(chdir (string directory))
|
||||
(to-scheme fixnum errno_or_false))
|
||||
|
||||
(define-errno-syscall (%chdir dir) %chdir/errno)
|
||||
(define-stubless-foreign %chdir (directory) "scsh_chdir")
|
||||
|
||||
;;; These calls change/reveal the process working directory
|
||||
;;;
|
||||
|
@ -139,54 +130,29 @@
|
|||
(let ((dir (:optional maybe-dir (home-dir))))
|
||||
(%chdir (ensure-file-name-is-nondirectory dir))))
|
||||
|
||||
|
||||
(define-foreign cwd/errno (scheme_cwd)
|
||||
(to-scheme fixnum "False_on_zero") ; errno or #f
|
||||
string) ; directory (or #f on error)
|
||||
|
||||
(define-errno-syscall (process-cwd) cwd/errno
|
||||
dir)
|
||||
|
||||
;; TODO: we get an error if cwd does not exist on startup
|
||||
(define-stubless-foreign process-cwd () "scheme_cwd")
|
||||
|
||||
;;; GID
|
||||
|
||||
(define-foreign user-gid (getgid) gid_t)
|
||||
(define-foreign user-effective-gid (getegid) gid_t)
|
||||
(define-stubless-foreign user-gid () "scsh_getgid")
|
||||
|
||||
(define-foreign set-gid/errno (setgid (gid_t id)) no-declare ; for SunOS 4.x
|
||||
(to-scheme fixnum errno_or_false))
|
||||
(define-stubless-foreign user-effective-gid () "scsh_getegid")
|
||||
|
||||
(define-errno-syscall (set-gid gid) set-gid/errno)
|
||||
(define-stubless-foreign set-gid (gid) "scsh_setgid")
|
||||
|
||||
(define-foreign %num-supplementary-gids/errno (num_supp_groups)
|
||||
(multi-rep (to-scheme fixnum errno_or_false)
|
||||
gid_t))
|
||||
|
||||
(define-foreign load-groups/errno (get_groups (vector-desc group-vec))
|
||||
(multi-rep (to-scheme fixnum errno_or_false)
|
||||
fixnum))
|
||||
|
||||
(define (user-supplementary-gids)
|
||||
(receive (err numgroups) (%num-supplementary-gids/errno)
|
||||
(if err (errno-error err user-supplementary-gids)
|
||||
(let ((vec (make-vector numgroups)))
|
||||
(receive (err numgroups2) (load-groups/errno vec)
|
||||
(if err (errno-error err user-supplementary-gids)
|
||||
(vector->list vec)))))))
|
||||
(define-stubless-foreign set-effective-gid (gid) "scsh_setegid")
|
||||
|
||||
(define-stubless-foreign user-supplementary-gids () "get_groups")
|
||||
|
||||
;;; UID
|
||||
(define-stubless-foreign user-uid () "scsh_getuid")
|
||||
|
||||
(define-foreign user-uid (getuid) uid_t)
|
||||
(define-foreign user-effective-uid (geteuid) uid_t)
|
||||
(define-stubless-foreign user-effective-uid () "scsh_geteuid")
|
||||
|
||||
(define-foreign set-uid/errno (setuid (uid_t id)) no-declare ; for SunOS 4.x
|
||||
(to-scheme fixnum errno_or_false))
|
||||
(define-stubless-foreign set-uid (uid) "scsh_setuid")
|
||||
|
||||
(define-errno-syscall (set-uid uid_t) set-uid/errno)
|
||||
|
||||
;;(define-foreign %user-login-name (my_username)
|
||||
;; static-string)
|
||||
(define-stubless-foreign set-effective-uid (uid) "scsh_seteuid")
|
||||
|
||||
(import-lambda-definition %user-login-name () "my_username")
|
||||
|
||||
|
@ -399,17 +365,9 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; STAT
|
||||
|
||||
(define-foreign stat-file/errno
|
||||
(scheme_stat (string path) (vector-desc data) (bool chase?))
|
||||
(to-scheme fixnum "False_on_zero")) ; errno or #f
|
||||
(define-stubless-foreign stat-file (path data chase?) "scheme_stat")
|
||||
|
||||
;(define-errno-syscall (stat-file fd data chase?) stat-file/errno)
|
||||
|
||||
(define-foreign stat-fdes/errno
|
||||
(scheme_fstat (integer fd) (vector-desc data))
|
||||
(to-scheme fixnum "False_on_zero")) ; errno or #f
|
||||
|
||||
;(define-errno-syscall (stat-fdes fd data) stat-fdes/errno)
|
||||
(define-stubless-foreign stat-fdes (fd data) "scheme_fstat")
|
||||
|
||||
(define-record file-info
|
||||
type
|
||||
|
@ -427,21 +385,18 @@
|
|||
|
||||
|
||||
;;; Should be redone to return multiple-values.
|
||||
(define (file-info/errno fd/port/fname chase?)
|
||||
(define (%file-info fd/port/fname chase?)
|
||||
(let ((ans-vec (make-vector 11))
|
||||
(file-type (lambda (type-code)
|
||||
(vector-ref '#(block-special char-special directory fifo
|
||||
regular socket symlink)
|
||||
type-code))))
|
||||
|
||||
(cond ((generic-file-op fd/port/fname
|
||||
(generic-file-op fd/port/fname
|
||||
(lambda (fd)
|
||||
(stat-fdes/errno fd ans-vec))
|
||||
(stat-fdes fd ans-vec))
|
||||
(lambda (fname)
|
||||
(stat-file/errno fname ans-vec chase?)))
|
||||
=> (lambda (err) (values err #f)))
|
||||
|
||||
(else (values #f (make-file-info (file-type (vector-ref ans-vec 0))
|
||||
(stat-file fname ans-vec chase?)))
|
||||
(make-file-info (file-type (vector-ref ans-vec 0))
|
||||
(vector-ref ans-vec 1)
|
||||
(vector-ref ans-vec 2)
|
||||
(vector-ref ans-vec 3)
|
||||
|
@ -451,15 +406,13 @@
|
|||
(vector-ref ans-vec 7)
|
||||
(vector-ref ans-vec 8)
|
||||
(vector-ref ans-vec 9)
|
||||
(vector-ref ans-vec 10)))))))
|
||||
(vector-ref ans-vec 10))))
|
||||
|
||||
|
||||
(define (file-info fd/port/fname . maybe-chase?)
|
||||
(with-cwd-aligned
|
||||
(let ((chase? (:optional maybe-chase? #t)))
|
||||
(receive (err info) (file-info/errno fd/port/fname chase?)
|
||||
(if err (errno-error err file-info fd/port/fname chase?)
|
||||
info)))))
|
||||
(%file-info fd/port/fname chase?))))
|
||||
|
||||
|
||||
(define file-attributes
|
||||
|
|
176
scsh/syscalls1.c
176
scsh/syscalls1.c
|
@ -79,7 +79,7 @@ s48_value wait_pid(s48_value s48_pid, s48_value s48_flags)
|
|||
** on the Scheme side.
|
||||
*/
|
||||
|
||||
int scheme_exec(const char *prog, s48_value argv, s48_value env)
|
||||
s48_value scheme_exec(s48_value prog, s48_value argv, s48_value env)
|
||||
{
|
||||
int i, j, e;
|
||||
int argc = S48_VECTOR_LENGTH(argv);
|
||||
|
@ -87,11 +87,11 @@ int scheme_exec(const char *prog, s48_value argv, s48_value env)
|
|||
char **unix_argv = Malloc(char*, argc+1);
|
||||
char **unix_env;
|
||||
|
||||
if( unix_argv == NULL ) return errno;
|
||||
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] = cig_string_body(S48_VECTOR_REF(argv,i));
|
||||
unix_argv[i] = s48_extract_string(S48_VECTOR_REF(argv,i));
|
||||
unix_argv[argc] = NULL;
|
||||
|
||||
/* Scheme->Unix convert the env parameter. */
|
||||
|
@ -100,24 +100,28 @@ int scheme_exec(const char *prog, s48_value argv, s48_value env)
|
|||
int envlen = S48_VECTOR_LENGTH(env);
|
||||
unix_env = Malloc(char*, envlen+1);
|
||||
|
||||
if( !unix_env ) goto lose;
|
||||
if( !unix_env ){
|
||||
Free(unix_argv);
|
||||
s48_raise_os_error_3(errno, prog, argv, env);
|
||||
}
|
||||
|
||||
for(j=0; j<envlen; j++)
|
||||
unix_env[j] = cig_string_body(S48_VECTOR_REF(env,j));
|
||||
unix_env[j] = s48_extract_string(S48_VECTOR_REF(env,j));
|
||||
unix_env[envlen] = NULL;
|
||||
}
|
||||
|
||||
execve(prog, unix_argv, unix_env); /* Do it. */
|
||||
execve(s48_extract_string (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;
|
||||
errno = e;
|
||||
return s48_enter_fixnum(errno); // Don't raise an exception since
|
||||
// we're maybe just testing the path
|
||||
}
|
||||
|
||||
s48_value scsh_exit(s48_value status)
|
||||
|
@ -161,7 +165,7 @@ 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(errno);
|
||||
s48_raise_os_error_2(errno, pid, signal);
|
||||
else return s48_enter_fixnum (ret);
|
||||
}
|
||||
|
||||
|
@ -173,7 +177,7 @@ 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(errno);
|
||||
s48_raise_os_error_1(errno, path);
|
||||
else
|
||||
{
|
||||
linkpath[retval] = '\0';
|
||||
|
@ -202,7 +206,7 @@ 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(errno);
|
||||
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. */
|
||||
|
@ -210,10 +214,16 @@ s48_value set_cloexec(s48_value _fd, s48_value _val)
|
|||
|
||||
flags = (flags & ~FD_CLOEXEC) | (val & FD_CLOEXEC);
|
||||
if (fcntl(fd, F_SETFD, flags) == -1)
|
||||
s48_raise_os_error(errno);
|
||||
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
|
||||
*******************************************************************************
|
||||
|
@ -231,7 +241,7 @@ s48_value set_cloexec(s48_value _fd, s48_value _val)
|
|||
#endif
|
||||
|
||||
/* Simple-minded POSIX version. */
|
||||
int scheme_cwd(const char **dirp)
|
||||
s48_value scheme_cwd()
|
||||
{
|
||||
char *buf;
|
||||
int size = scsh_path_max + 1; /* +1 for terminating nul byte... */
|
||||
|
@ -248,40 +258,15 @@ int scheme_cwd(const char **dirp)
|
|||
buf = nbuf;
|
||||
}
|
||||
|
||||
*dirp = (const char*) buf; /* win */
|
||||
return 0;
|
||||
return s48_enter_string(buf); /* win */
|
||||
|
||||
lose:
|
||||
{int e = errno;
|
||||
Free(buf);
|
||||
*dirp = 0;
|
||||
return e;}
|
||||
errno = e,
|
||||
s48_raise_os_error(errno);}
|
||||
}
|
||||
|
||||
|
||||
#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
|
||||
*******************************************************************************
|
||||
*/
|
||||
|
@ -365,12 +350,10 @@ ssize_t write_fdes_substring(s48_value buf, size_t start, size_t end, int fd)
|
|||
*/
|
||||
|
||||
/* Internal aux function -- loads stat values into Scheme vector: */
|
||||
static int really_stat(int retval, struct stat *s, s48_value vec)
|
||||
s48_value really_stat(struct stat *s, s48_value vec)
|
||||
{
|
||||
int modes, typecode = -1;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
if( 11 != S48_VECTOR_LENGTH(vec) ) return -1;
|
||||
if( retval < 0 ) return errno;
|
||||
|
||||
S48_GC_PROTECT_1(vec);
|
||||
|
||||
|
@ -399,19 +382,26 @@ static int really_stat(int retval, struct stat *s, s48_value vec)
|
|||
These aren't POSIX, and, e.g., are not around on SGI machines.
|
||||
Too bad -- blksize is useful. Unix sux. */
|
||||
S48_GC_UNPROTECT();
|
||||
return 0;
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
int scheme_stat(const char *path, s48_value vec, int chase_p)
|
||||
s48_value scheme_stat(s48_value path, s48_value vec, s48_value chase_p)
|
||||
{
|
||||
struct stat s;
|
||||
return really_stat(chase_p ? stat(path, &s) : lstat(path, &s), &s, vec);
|
||||
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);
|
||||
}
|
||||
|
||||
int scheme_fstat(int fd, s48_value vec)
|
||||
s48_value scheme_fstat(s48_value fd, s48_value vec)
|
||||
{
|
||||
struct stat s;
|
||||
return really_stat(fstat(fd,&s), &s, vec);
|
||||
int retval = fstat (s48_extract_fixnum (fd), &s);
|
||||
if (retval == -1) s48_raise_os_error_1 (errno, fd);
|
||||
return really_stat (&s, vec);
|
||||
}
|
||||
|
||||
|
||||
|
@ -419,32 +409,89 @@ int scheme_fstat(int fd, s48_value vec)
|
|||
*******************************************************************************
|
||||
*/
|
||||
|
||||
int num_supp_groups(void)
|
||||
s48_value scsh_getgid()
|
||||
{
|
||||
return getgroups(0,NULL);
|
||||
return s48_enter_integer(getgid());
|
||||
}
|
||||
|
||||
/* Load the supplementary groups into GVEC. */
|
||||
|
||||
int get_groups(s48_value gvec)
|
||||
s48_value scsh_getegid()
|
||||
{
|
||||
int veclen = S48_VECTOR_LENGTH(gvec), i, retval;
|
||||
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)) ) return -1;
|
||||
if (NULL == (gp=Malloc(gid_t,veclen))) s48_raise_os_error(errno);
|
||||
|
||||
retval = getgroups(veclen, gp);
|
||||
|
||||
if( retval != -1 )
|
||||
for( i=veclen; i--; )
|
||||
S48_VECTOR_SET(gvec,i, s48_enter_fixnum(gp[i]));
|
||||
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);
|
||||
if (veclen > 20) Free(gp);
|
||||
|
||||
return retval;
|
||||
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
|
||||
*******************************************************************************
|
||||
|
@ -663,7 +710,8 @@ s48_value scm_gethostname(void)
|
|||
char hostname[MAXHOSTNAMELEN+1];
|
||||
/* different OS's declare differently, so punt the prototype. */
|
||||
int gethostname();
|
||||
gethostname(hostname, MAXHOSTNAMELEN);
|
||||
int retval = gethostname(hostname, MAXHOSTNAMELEN);
|
||||
if (retval == -1) s48_raise_os_error(errno);
|
||||
return s48_enter_string(hostname);
|
||||
}
|
||||
|
||||
|
@ -695,7 +743,7 @@ 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(errno);
|
||||
s48_raise_os_error_2(errno, fd, command);
|
||||
else return s48_enter_fixnum (ret);
|
||||
}
|
||||
|
||||
|
@ -706,7 +754,7 @@ s48_value fcntl_write(s48_value fd, s48_value command, s48_value value)
|
|||
s48_extract_integer (command),
|
||||
s48_extract_integer (value));
|
||||
if (ret == -1)
|
||||
s48_raise_os_error(errno);
|
||||
s48_raise_os_error_3(errno, fd, command, value);
|
||||
else return s48_enter_fixnum (ret);
|
||||
}
|
||||
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
s48_value wait_pid(s48_value pid, s48_value flags);
|
||||
|
||||
int scheme_exec(const char *prog, s48_value argv, s48_value env);
|
||||
s48_value scheme_exec(s48_value prog, s48_value argv, s48_value env);
|
||||
|
||||
s48_value scsh_exit (s48_value status);
|
||||
|
||||
|
@ -22,7 +22,9 @@ int scm_utime_now(char const *path);
|
|||
|
||||
s48_value set_cloexec(s48_value _fd, s48_value _val);
|
||||
|
||||
int scheme_cwd(const char **dirp);
|
||||
s48_value scsh_chdir(s48_value directory);
|
||||
|
||||
s48_value scheme_cwd();
|
||||
|
||||
int process_times(clock_t *utime, clock_t *stime,
|
||||
clock_t *cutime, clock_t *cstime);
|
||||
|
@ -41,13 +43,27 @@ ssize_t write_fdes_substring(s48_value buf, size_t start, size_t end, int fd);
|
|||
|
||||
int write_stream_substring(s48_value buf, int start, int end, FILE *f);
|
||||
|
||||
int scheme_stat(const char *path, s48_value vec, int chase_p);
|
||||
s48_value scheme_stat(s48_value path, s48_value vec, s48_value chase_p);
|
||||
|
||||
int scheme_fstat(int fd, s48_value vec);
|
||||
s48_value scheme_fstat(s48_value fd, s48_value vec);
|
||||
|
||||
int num_supp_groups(void);
|
||||
s48_value scsh_getgid();
|
||||
|
||||
int get_groups(s48_value gvec);
|
||||
s48_value scsh_getegid();
|
||||
|
||||
s48_value scsh_setgid(s48_value gid);
|
||||
|
||||
s48_value scsh_setegid(s48_value gid);
|
||||
|
||||
s48_value get_groups();
|
||||
|
||||
s48_value scsh_getuid();
|
||||
|
||||
s48_value scsh_geteuid();
|
||||
|
||||
s48_value scsh_setuid(s48_value uid);
|
||||
|
||||
s48_value scsh_seteuid(s48_value uid);
|
||||
|
||||
int put_env(const char *s);
|
||||
|
||||
|
|
Loading…
Reference in New Issue