removed reap-zombies from fork; renamed cwd and chdir to process-X to support cwd per thread;read-symlink and get-hostname communicate via scheme-strings to omit the static strings; support for environ per thread, but some things are missing; added a first version of crypt
This commit is contained in:
marting
parent
85cff767c0
commit
539638acbd
|
|
@ -88,6 +88,8 @@
|
|||
(desc env)) ; string vector or #t.
|
||||
fixnum)
|
||||
|
||||
;; we can't algin env here, because exec-path/env calls
|
||||
;; %%exec/errno directly F*&% *P
|
||||
(define (%%exec prog argv env)
|
||||
(errno-error (%%exec/errno prog argv env) %exec prog argv env)) ; cute.
|
||||
|
||||
|
|
@ -122,13 +124,9 @@
|
|||
;;; This ugly little hack will have to stay in until I do early
|
||||
;;; zombie reaping with SIGCHLD interrupts.
|
||||
|
||||
;; JMG: this should spawn a thread to prevent deadlocking the vm
|
||||
(define (%%fork-with-retry/errno)
|
||||
(receive (err pid) (%%fork/errno)
|
||||
(cond ((and err (eq? 'early (autoreap-policy)))
|
||||
(reap-zombies)
|
||||
(%%fork/errno))
|
||||
(else (values err pid)))))
|
||||
(values err pid)))
|
||||
|
||||
(define-errno-syscall (%%fork) %%fork-with-retry/errno
|
||||
pid)
|
||||
|
|
@ -151,9 +149,10 @@
|
|||
|
||||
(define-errno-syscall (%chdir dir) %chdir/errno)
|
||||
|
||||
;;; JMG: this may block
|
||||
;;; These calls change/reveal the process working directory
|
||||
;;;
|
||||
|
||||
(define (chdir . maybe-dir)
|
||||
(define (process-chdir . maybe-dir)
|
||||
(let ((dir (:optional maybe-dir (home-dir))))
|
||||
(%chdir (ensure-file-name-is-nondirectory dir))))
|
||||
|
||||
|
|
@ -162,7 +161,7 @@
|
|||
(to-scheme fixnum "False_on_zero") ; errno or #f
|
||||
string) ; directory (or #f on error)
|
||||
|
||||
(define-errno-syscall (cwd) cwd/errno
|
||||
(define-errno-syscall (process-cwd) cwd/errno
|
||||
dir)
|
||||
|
||||
|
||||
|
|
@ -257,7 +256,7 @@
|
|||
;;; PROCESS TIMES
|
||||
|
||||
;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away.
|
||||
;;; OOPS: The ret values should be clock_t, not int, but cig can't handle it.
|
||||
|
||||
|
||||
(define-foreign process-times/errno (process_times)
|
||||
(to-scheme integer errno_or_false)
|
||||
|
|
@ -372,8 +371,11 @@
|
|||
|
||||
|
||||
(define-foreign read-symlink/errno (scm_readlink (string path))
|
||||
(multi-rep (to-scheme string errno_on_zero_or_false) ; NULL => errno, otw #f
|
||||
static-string))
|
||||
desc
|
||||
desc)
|
||||
|
||||
;(to-scheme string errno_on_zero_or_false) ; NULL => errno, otw #f
|
||||
; static-string))
|
||||
|
||||
(define-errno-syscall (read-symlink path) read-symlink/errno
|
||||
new-path)
|
||||
|
|
@ -872,6 +874,8 @@
|
|||
|
||||
;;; (var . val) / "var=val" rep conversion:
|
||||
|
||||
|
||||
|
||||
(define (split-env-string var=val)
|
||||
(let ((i (string-index var=val #\=)))
|
||||
(if i (values (substring var=val 0 i)
|
||||
|
|
@ -899,50 +903,60 @@
|
|||
(receive (C-env nelts) (%load-env)
|
||||
(vector->list (C-string-vec->Scheme C-env nelts))))
|
||||
|
||||
(define (env->alist) (env-list->alist (env->list)))
|
||||
(define (environ-env->alist)
|
||||
(env-list->alist (env->list)))
|
||||
|
||||
|
||||
|
||||
;;; ALIST->ENV
|
||||
|
||||
(define-foreign %install-env/errno
|
||||
(define-foreign %install-env/errno
|
||||
(install_env (vector-desc env-vec))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-errno-syscall (%install-env env-vec) %install-env/errno)
|
||||
|
||||
(define (alist->env alist)
|
||||
;;; assumes aligned env
|
||||
(define (envvec-alist->env alist)
|
||||
(%install-env (alist->env-vec alist)))
|
||||
|
||||
;;; GETENV, PUTENV, SETENV
|
||||
;;; create new env for thread
|
||||
(define-foreign %create-env/errno
|
||||
(create_env (vector-desc env-vec))
|
||||
(to-scheme integer errno_or_false)
|
||||
desc)
|
||||
|
||||
(define-foreign getenv (getenv (string var))
|
||||
(define-errno-syscall (%create-env env-vec)
|
||||
%create-env/errno
|
||||
bvec)
|
||||
|
||||
(define (alist->envvec alist)
|
||||
(%create-env (alist->env-vec alist)))
|
||||
|
||||
(define-foreign %align-env
|
||||
(align_env (desc))
|
||||
ignore)
|
||||
|
||||
;;; GETENV, SETENV
|
||||
;;; they all assume an aligned env
|
||||
|
||||
|
||||
(define-foreign %envvec-setenv (envvec_setenv (desc name) (desc entry))
|
||||
desc)
|
||||
|
||||
(define (envvec-setenv name value)
|
||||
(%envvec-setenv name (string-append name "=" value)))
|
||||
|
||||
(define-foreign envvec-getenv (getenv (string var))
|
||||
static-string)
|
||||
|
||||
(foreign-source
|
||||
"#define errno_on_nonzero_or_false(x) ((x) ? s48_enter_fixnum(errno) : S48_FALSE)"
|
||||
"" "")
|
||||
|
||||
;(define-foreign putenv/errno
|
||||
; (put_env (string var=val))
|
||||
; desc) ; #f or errno
|
||||
|
||||
|
||||
;;; putenv takes a constant: const char *, cig can't figure that out..
|
||||
(define-foreign putenv/errno
|
||||
(putenv (string-copy var=val)) no-declare
|
||||
(to-scheme fixnum errno_on_nonzero_or_false)) ; #f or errno
|
||||
|
||||
(define-foreign delete-env (delete_env (string var))
|
||||
(define-foreign envvec-delete-env (delete_env (string var))
|
||||
ignore)
|
||||
|
||||
(define (putenv var=val)
|
||||
(if (putenv/errno var=val)
|
||||
(error "malloc failure in putenv" var=val)))
|
||||
|
||||
(define (setenv var val)
|
||||
(if val
|
||||
(putenv (string-append var "=" val))
|
||||
(delete-env var)))
|
||||
|
||||
|
||||
;;; Fd-ports
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -1012,11 +1026,23 @@
|
|||
desc)
|
||||
|
||||
(define-foreign %gethostname (scm_gethostname)
|
||||
static-string)
|
||||
desc)
|
||||
|
||||
(define system-name %gethostname)
|
||||
|
||||
(define-foreign errno-msg (errno_msg (integer i))
|
||||
static-string)
|
||||
|
||||
(define-foreign %crypt (scm_crypt (desc key) (desc salt))
|
||||
desc)
|
||||
|
||||
(define (crypt key salt)
|
||||
(let* ((allowed-char-set (rx (| alpha digit "." "/")))
|
||||
(salt-regexp (rx (: ,allowed-char-set ,allowed-char-set))))
|
||||
(if (not (= (string-length salt) 2)) (error "salt must have length 2"))
|
||||
(if (not (regexp-search? salt-regexp salt))
|
||||
(error "illegal char in salt " salt))
|
||||
(if (> (string-length key) 8) (error "key too long " (string-length key)))
|
||||
(%crypt key salt)))
|
||||
|
||||
|
||||
|
|
|
|||
196
scsh/syscalls1.c
196
scsh/syscalls1.c
|
|
@ -31,6 +31,7 @@
|
|||
#include <unistd.h>
|
||||
#include <string.h>
|
||||
#include <utime.h>
|
||||
//#include <crypt.h> TODO: adapt configure to figure out if needed
|
||||
|
||||
#include "cstuff.h"
|
||||
#include "machine/stdio_dep.h"
|
||||
|
|
@ -131,14 +132,18 @@ int scheme_pipe(int *r, int *w)
|
|||
|
||||
/* Read the symlink into static memory. Return NULL on error. */
|
||||
|
||||
static char linkpath[MAXPATHLEN+1]; /* Maybe unaligned. Not reentrant. */
|
||||
// JMG: static char linkpath[MAXPATHLEN+1]; /* Maybe unaligned. Not reentrant. */
|
||||
|
||||
char const *scm_readlink(const char *path)
|
||||
s48_value scm_readlink(const char *path, s48_value *ret_string)
|
||||
{
|
||||
char linkpath[MAXPATHLEN+1];
|
||||
int retval = readlink(path, linkpath, MAXPATHLEN);
|
||||
|
||||
return (char const *)
|
||||
((retval == -1) ? NULL : ( linkpath[retval] = '\0', linkpath ));
|
||||
if (retval != -1){
|
||||
linkpath[retval] = '\0';
|
||||
*ret_string = s48_enter_string(linkpath);
|
||||
return S48_FALSE;
|
||||
}
|
||||
return s48_enter_fixnum(errno);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -315,6 +320,7 @@ ssize_t write_fdes_substring(s48_value buf, size_t start, size_t end, int fd)
|
|||
** I haven't bothered w/anything else, since the only other real limit
|
||||
** is size -- files can't be bigger than .5Gb.
|
||||
*/
|
||||
// JMG: removed time_hacks
|
||||
|
||||
/* S_ISSOCK(mode) and S_ISLNK(mode) are not POSIX. You lose on a NeXT. Ugh. */
|
||||
#ifndef S_ISSOCK
|
||||
|
|
@ -336,10 +342,12 @@ ssize_t write_fdes_substring(s48_value buf, size_t start, size_t end, int fd)
|
|||
static int really_stat(int retval, struct stat *s, s48_value vec)
|
||||
{
|
||||
int modes, typecode = -1;
|
||||
|
||||
if( 11 != S48_VECTOR_LENGTH(vec) ) return -1;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
if( 11 != S48_VECTOR_LENGTH(vec) ) return -1;
|
||||
if( retval < 0 ) return errno;
|
||||
|
||||
|
||||
S48_GC_PROTECT_1(vec);
|
||||
|
||||
modes = s->st_mode;
|
||||
if( S_ISBLK(modes) ) typecode = 0;
|
||||
else if( S_ISCHR(modes) ) typecode = 1;
|
||||
|
|
@ -357,7 +365,6 @@ static int really_stat(int retval, struct stat *s, s48_value vec)
|
|||
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_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));
|
||||
|
|
@ -365,7 +372,7 @@ static int really_stat(int retval, struct stat *s, s48_value vec)
|
|||
/* 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 0;
|
||||
}
|
||||
|
||||
|
|
@ -416,15 +423,90 @@ int get_groups(s48_value gvec)
|
|||
/* Environment hackery
|
||||
*******************************************************************************
|
||||
*/
|
||||
struct envvec {
|
||||
char **env; /* Null-terminated vector of strings. Malloc'd. */
|
||||
int size; /* Length of env. */
|
||||
int revealed; /* True => exported to C code */
|
||||
int gcable; /* True => no pointers to us from Scheme heap. */
|
||||
};
|
||||
/* Note that the SIZE field tells you how many words of memory are allocated
|
||||
** for the block of memory to which the ENV field points. This includes the
|
||||
** terminating null pointer, and may include more words beyond that. It is
|
||||
** *not* the number of strings stored in ENV; it is always greater than this
|
||||
** value.
|
||||
**
|
||||
** The REVEALED field is incremented if either the ENV block or the entire
|
||||
** struct is handed out to C code.
|
||||
**
|
||||
** If the structure becomes gc'able, but is REVEALED (hence cannot be freed),
|
||||
** the GC simply sets GCABLE and forgets about it.
|
||||
*/
|
||||
|
||||
int put_env(const char *s)
|
||||
{
|
||||
char *s1 = Malloc(char, strlen(s)+1);
|
||||
if( !s1 ) return s48_enter_fixnum(errno);
|
||||
|
||||
strcpy(s1, s);
|
||||
/* 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
|
||||
*/
|
||||
struct envvec *current_env = 0;
|
||||
|
||||
return putenv(s1) ? s48_enter_fixnum(errno) : S48_FALSE;
|
||||
void align_env(s48_value pointer_to_struct)
|
||||
{
|
||||
struct envvec* thread_env;
|
||||
thread_env = (struct envvec*) s48_extract_integer(pointer_to_struct);
|
||||
environ = thread_env->env;
|
||||
current_env = thread_env;
|
||||
}
|
||||
|
||||
|
||||
|
||||
int envvec_setenv(s48_value scheme_name, s48_value entry){
|
||||
char * name = s48_extract_string(scheme_name);
|
||||
int namelen = strlen(name);
|
||||
char **ptr = environ;
|
||||
char ** newenv;
|
||||
int size = current_env->size;
|
||||
int number_of_entries = 0;
|
||||
char * newentry = Malloc(char, S48_STRING_LENGTH(entry) + 1);
|
||||
if ( !newentry) return s48_enter_fixnum(errno);
|
||||
|
||||
if (!current_env) {
|
||||
fprintf(stderr, "no current_env, giving up" );
|
||||
exit (1);
|
||||
}
|
||||
|
||||
while (*ptr){
|
||||
if ( ( strncmp(*ptr, name, namelen) == 0) && (*ptr)[namelen] == '=')
|
||||
{
|
||||
*ptr = strcpy(newentry,s48_extract_string(entry));
|
||||
return S48_FALSE;
|
||||
}
|
||||
ptr++;
|
||||
number_of_entries++;
|
||||
}
|
||||
if (number_of_entries >= size) { // I never had this problem, but...
|
||||
fprintf(stderr, "currupt env, giving up %d %d", number_of_entries,size);
|
||||
exit (1);
|
||||
}
|
||||
else if (number_of_entries < (size - 1)) // is space left after the NULL ?
|
||||
{
|
||||
*ptr = strcpy(newentry,s48_extract_string(entry));
|
||||
*++ptr = NULL;
|
||||
return S48_FALSE;
|
||||
}
|
||||
else // number_of_entries == (size - 1)
|
||||
{
|
||||
int newsize = size + 1; // TODO: add more
|
||||
char ** newenv = Malloc (char *, newsize);
|
||||
if( !newenv) return s48_enter_fixnum(errno);
|
||||
current_env->env = newenv;
|
||||
current_env->size = newsize;
|
||||
memcpy(newenv, environ, number_of_entries * sizeof (char *));
|
||||
newenv[number_of_entries] = strcpy(newentry, s48_extract_string(entry));
|
||||
newenv[number_of_entries + 1] = NULL;
|
||||
environ = newenv;
|
||||
return S48_FALSE;
|
||||
}
|
||||
}
|
||||
|
||||
char** scm_envvec(int *len) /* Returns environ c-vector & its length. */
|
||||
|
|
@ -447,9 +529,16 @@ int install_env(s48_value vec)
|
|||
char **newenv;
|
||||
|
||||
envsize = S48_VECTOR_LENGTH(vec);
|
||||
newenv = Malloc(char*, envsize+1);
|
||||
if( !newenv ) return errno;
|
||||
|
||||
|
||||
if (envsize >= (current_env->size))
|
||||
{
|
||||
newenv = Malloc(char*, envsize+1);
|
||||
if( !newenv ) return errno;
|
||||
Free(current_env->env);
|
||||
current_env->env = newenv;
|
||||
}
|
||||
else newenv = current_env->env;
|
||||
|
||||
for( i=0; i<envsize; i++ ) {
|
||||
char *s = scheme2c_strcpy(S48_VECTOR_REF(vec,i));
|
||||
if (!s) {
|
||||
|
|
@ -467,33 +556,73 @@ int install_env(s48_value vec)
|
|||
return 0;
|
||||
}
|
||||
|
||||
int create_env(s48_value vec, s48_value * envvec_addr)
|
||||
{
|
||||
int i, envsize;
|
||||
char **newenv;
|
||||
struct envvec* thread_env;
|
||||
|
||||
envsize = S48_VECTOR_LENGTH(vec);
|
||||
|
||||
newenv = Malloc(char*, envsize+1);
|
||||
if( !newenv ) return errno;
|
||||
thread_env = Malloc (struct envvec, 4);
|
||||
if( !thread_env ) {
|
||||
Free (newenv);
|
||||
return errno;
|
||||
}
|
||||
|
||||
thread_env->env = newenv;
|
||||
thread_env->size = envsize + 1;
|
||||
thread_env->revealed = 0;
|
||||
thread_env->gcable = 0;
|
||||
|
||||
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);
|
||||
Free(thread_env);
|
||||
return e;
|
||||
}
|
||||
newenv[i] = s;
|
||||
}
|
||||
|
||||
newenv[envsize] = NULL;
|
||||
|
||||
*envvec_addr = s48_enter_integer((long) thread_env);
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Delete the env var. */
|
||||
void delete_env(const char *var)
|
||||
{
|
||||
int varlen = strlen(var);
|
||||
char **ptr = environ-1;
|
||||
|
||||
char **ptr2;
|
||||
do if( !*++ptr ) return;
|
||||
while( strncmp(*ptr, var, varlen) || (*ptr)[varlen] != '=' );
|
||||
|
||||
do ptr[0] = ptr[1]; while( *++ptr );
|
||||
ptr2 = ptr;
|
||||
while (*++ptr2);
|
||||
*ptr = *ptr2;
|
||||
*ptr2 = NULL;
|
||||
}
|
||||
|
||||
|
||||
/*****************************************************************************/
|
||||
|
||||
/* N.B.: May be unaligned.
|
||||
** Not re-entrant, either -- will puke if multithreaded.
|
||||
*/
|
||||
static char hostname[MAXHOSTNAMELEN+1];
|
||||
/* N.B.: May be unaligned. */
|
||||
|
||||
char *scm_gethostname(void)
|
||||
s48_value scm_gethostname(void)
|
||||
{
|
||||
char hostname[MAXHOSTNAMELEN+1];
|
||||
/* different OS's declare differently, so punt the prototype. */
|
||||
int gethostname();
|
||||
gethostname(hostname, MAXHOSTNAMELEN);
|
||||
return hostname;
|
||||
return s48_enter_string(hostname);
|
||||
}
|
||||
|
||||
#include <errno.h>
|
||||
|
|
@ -525,3 +654,12 @@ int fcntl_read(int fd, int command)
|
|||
|
||||
int fcntl_write(int fd, int command, int value)
|
||||
{ return fcntl(fd, command, value); }
|
||||
|
||||
/* crypt()
|
||||
******************
|
||||
*/
|
||||
s48_value scm_crypt(s48_value key, s48_value salt)
|
||||
{
|
||||
return s48_enter_string (crypt ( s48_extract_string (key),
|
||||
s48_extract_string(salt)));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ int scheme_exec(const char *prog, s48_value argv, s48_value env);
|
|||
|
||||
int scheme_pipe(int *r, int *w);
|
||||
|
||||
char const *scm_readlink(const char *path);
|
||||
s48_value scm_readlink(const char *path, s48_value*);
|
||||
|
||||
int scm_utime(char const *path, time_t ac, time_t mod);
|
||||
|
||||
|
|
@ -47,10 +47,12 @@ int install_env(s48_value vec);
|
|||
|
||||
void delete_env(const char *var);
|
||||
|
||||
char *scm_gethostname(void);
|
||||
s48_value scm_gethostname(void);
|
||||
|
||||
char *errno_msg(int i);
|
||||
|
||||
int fcntl_read(int fd, int command);
|
||||
|
||||
int fcntl_write(int fd, int command, int value);
|
||||
|
||||
s48_value scm_crypt(s48_value key, s48_value salt);
|
||||
|
|
|
|||
Loading…
Reference in New Issue