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

scsh/syscalls.scm

@@ -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)))
+	   (values err pid)))
-	   (reap-zombies)
-	   (%%fork/errno))
-	  (else (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
+ desc
-	     static-string))
+ 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,7 +903,10 @@
   (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
 
@@ -909,40 +916,47 @@
 
 (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
+(define-foreign envvec-delete-env (delete_env (string var))
-;  (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))
   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)))
+        
 	

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);
-
+  if (retval != -1){
-  return (char const *)
+    linkpath[retval] = '\0';
-      ((retval == -1) ? NULL : ( linkpath[retval] = '\0', linkpath ));
+    *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;
-
+  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)
+/* 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;
+
+void align_env(s48_value pointer_to_struct)
   { 
-  char *s1 = Malloc(char, strlen(s)+1);
+    struct envvec* thread_env;
-  if( !s1 ) return s48_enter_fixnum(errno);
+    thread_env =  (struct envvec*) s48_extract_integer(pointer_to_struct);
+    environ = thread_env->env; 
+    current_env = thread_env; 
+}
 
-  strcpy(s1, s);
 
-  return putenv(s1) ? s48_enter_fixnum(errno) : S48_FALSE;
+
+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,8 +529,15 @@ int install_env(s48_value vec)
   char **newenv;
 
   envsize = S48_VECTOR_LENGTH(vec);
+  
+  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));
@@ -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] != '=' );
-
+  ptr2 = ptr;
-  do ptr[0] = ptr[1]; while( *++ptr ); 
+  while (*++ptr2);
+  *ptr = *ptr2;
+  *ptr2 = NULL;
 }	
 
 
 /*****************************************************************************/
 
-/* N.B.: May be unaligned. 
+/* N.B.: May be unaligned. */
-** Not re-entrant, either -- will puke if multithreaded.
-*/
-static char hostname[MAXHOSTNAMELEN+1]; 
 
-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)));
+}

scsh/syscalls1.h

@@ -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);