From 4ce666c8d6a4904b395e6513f44d8aa4cd06ad23 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@gmail.com>
Date: Wed, 2 Sep 2009 22:47:57 +0300
Subject: [PATCH] applied patch from andreas rottmann for providing "process*"
 which is the kitchen sink of subprocess creation.

---
 scheme/ikarus.io.ss  | 116 +++++++++++++++++++++----------------
 scheme/last-revision |   2 +-
 scheme/makefile.ss   |   1 +
 src/ikarus-process.c | 134 ++++++++++++++++++++++++++++++++++++-------
 4 files changed, 182 insertions(+), 71 deletions(-)

diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss
index 7985879..6563536 100644
--- a/scheme/ikarus.io.ss
+++ b/scheme/ikarus.io.ss
@@ -65,7 +65,8 @@
     input-port-byte-position
     input-port-column-number input-port-row-number
     process process-nonblocking
-    
+    process*
+
     tcp-connect tcp-connect-nonblocking
     udp-connect udp-connect-nonblocking
     tcp-server-socket tcp-server-socket-nonblocking
@@ -2320,59 +2321,74 @@
 
 
 
+  (define (pair->env-utf8 pair)
+    (let* ((key-utf8 (string->utf8 (car pair)))
+           (val-utf8 (string->utf8 (cdr pair)))
+           (key-len (bytevector-length key-utf8))
+           (val-len (bytevector-length val-utf8))
+           (result (make-bytevector (+ key-len val-len 2))))
+      (bytevector-copy! key-utf8 0 result 0 key-len)
+      (bytevector-u8-set! result key-len (char->integer #\=))
+      (bytevector-copy! val-utf8 0 result (+ key-len 1) val-len)
+      (bytevector-u8-set! result (+ key-len val-len 1) 0)
+      result))
+  
+  (define (spawn-process who search? blocking? env stdin stdout stderr cmd args)
+    (define (port->fd port port-pred arg-name port-type)
+      (cond ((eqv? port #f) -1)
+            ((port-pred port)
+             (let ((fd (cookie-dest ($port-cookie port))))
+               (unless (fixnum? fd)
+                 (die who
+                      (string-append arg-name " is not a file-based port")
+                      stdin))
+               fd))
+            (else
+             (die who
+                  (string-append arg-name " is neither false nor an " port-type)
+                  stdin))))
+    (let ((stdin-fd (port->fd stdin input-port? "stdin" "input port"))
+          (stdout-fd (port->fd stdout output-port? "stdout" "output port"))
+          (stderr-fd (port->fd stderr output-port? "stderr" "output port")))
+      (unless (string? cmd)
+        (die who "command is not a string" cmd))
+      (unless (andmap string? args) 
+        (die who "all command arguments must be strings"))
+      (let ([r (foreign-call "ikrt_process"
+                             (vector search? stdin-fd stdout-fd stderr-fd)
+                             (and env (map pair->env-utf8 env))
+                             (string->utf8 cmd)
+                             (map string->utf8 (cons cmd args)))])
+        (cond ((fixnum? r)
+               (io-error who cmd r))
+              (else
+               (unless blocking?
+                 (or stdin (set-fd-nonblocking (vector-ref r 1) who cmd))
+                 (or stdout (set-fd-nonblocking (vector-ref r 2) who cmd))
+                 (or stderr (set-fd-nonblocking (vector-ref r 3) who cmd)))
+               (values
+                (vector-ref r 0)        ; pid
+                (and (not stdin)
+                     (fh->output-port (vector-ref r 1) 
+                                      cmd output-file-buffer-size #f #t
+                                      'process))
+                (and (not stdout)
+                     (fh->input-port (vector-ref r 2) 
+                                     cmd input-file-buffer-size #f #t
+                                     'process))
+                (and (not stderr)
+                     (fh->input-port (vector-ref r 3) 
+                                     cmd input-file-buffer-size #f #t
+                                     'process))))))))
+  
   (define (process cmd . args)
-    (define who 'process)
-    (unless (string? cmd)
-      (die who "command is not a string" cmd))
-    (unless (andmap string? args) 
-      (die who "all arguments must be strings"))
-    (let ([r (foreign-call "ikrt_process" 
-                (make-vector 4)
-                (string->utf8 cmd)
-                (map string->utf8 (cons cmd args)))])
-      (if (fixnum? r) 
-          (io-error who cmd r)
-          (values
-            (vector-ref r 0) ; pid
-            (fh->output-port (vector-ref r 1) 
-                cmd output-file-buffer-size #f #t
-                'process)
-            (fh->input-port (vector-ref r 2) 
-                cmd input-file-buffer-size #f #t
-                'process)
-            (fh->input-port (vector-ref r 3) 
-                cmd input-file-buffer-size #f #t
-                'process)))))
+    (spawn-process 'process #t #t #f #f #f #f cmd args))
 
+  (define (process* search? env stdin stdout stderr cmd . args)
+    (spawn-process 'process* search? #t env stdin stdout stderr cmd args))
 
   (define (process-nonblocking cmd . args)
-    (define who 'process-nonblocking)
-    (unless (string? cmd)
-      (die who "command is not a string" cmd))
-    (unless (andmap string? args) 
-      (die who "all arguments must be strings"))
-    (let ([r (foreign-call "ikrt_process" 
-                (make-vector 4)
-                (string->utf8 cmd)
-                (map string->utf8 (cons cmd args)))])
-      (if (fixnum? r) 
-          (io-error who cmd r)
-          (begin 
-            (set-fd-nonblocking (vector-ref r 1) who cmd)
-            (set-fd-nonblocking (vector-ref r 2) who cmd)
-            (set-fd-nonblocking (vector-ref r 3) who cmd)
-            (values
-              (vector-ref r 0) ; pid
-              (fh->output-port (vector-ref r 1) 
-                  cmd output-file-buffer-size #f #t
-                  'process)
-              (fh->input-port (vector-ref r 2) 
-                  cmd input-file-buffer-size #f #t
-                  'process)
-              (fh->input-port (vector-ref r 3) 
-                  cmd input-file-buffer-size #f #t
-                  'process))))))
-
+    (spawn-process 'process-nonblocking #t #f #f #f #f cmd args))
 
   (define (set-fd-nonblocking fd who id)
     (let ([rv (foreign-call "ikrt_make_fd_nonblocking" fd)])
diff --git a/scheme/last-revision b/scheme/last-revision
index 0b76d65..881d986 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1851
+1852
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 27fa0e7..6348e99 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -421,6 +421,7 @@
     [pointer-value                               i]
     [system                                      i]
     [process                                     i]
+    [process*                                    i]
     [process-nonblocking                         i]
     [waitpid                                     i]
     [wstatus-pid                                 i]
diff --git a/src/ikarus-process.c b/src/ikarus-process.c
index 7dde9ed..6f84146 100644
--- a/src/ikarus-process.c
+++ b/src/ikarus-process.c
@@ -52,40 +52,134 @@ list_to_vec(ikptr x){
   return vec;
 }
 
+static int
+execvpe_(const char *cmd, char *const *argv, char *const *envp){
+  char *path = NULL;
+  const char *searchpath;
+  const char *sep;
+  size_t cmd_len;
+  
+  if (cmd[0] == '/')
+    execve(cmd, argv, envp);
+  
+  searchpath = getenv("PATH");
+  if (searchpath == NULL)
+    searchpath = "/bin:/usr/bin";
+
+  cmd_len = strlen(cmd);
+  
+  sep = NULL;
+  do {
+    size_t prefix_len, path_len;
+    
+    sep = strchr(searchpath, ':');
+    if (sep == NULL) {
+      sep = searchpath + strlen(searchpath);
+    }
+    
+    prefix_len = (sep - searchpath);
+    path_len = prefix_len + cmd_len + 2;
+    path = realloc(path, path_len);
+    if (path == NULL) {
+      errno = ENOMEM;
+      return -1;
+    }
+    memcpy(path, searchpath, prefix_len);
+    if (prefix_len == 0 || searchpath[prefix_len - 1] == '/') {
+      memcpy(path + prefix_len, cmd, cmd_len + 1);
+    } else {
+      path[prefix_len] = '/';
+      memcpy(path + prefix_len + 1, cmd, cmd_len + 1);
+    }
+    
+    execve(path, argv, envp);
+    switch (errno) {
+    case E2BIG:
+    case ENOEXEC:
+    case ENOMEM:
+    case ETXTBSY:
+      break; /* these are treated as error, abort search */
+    }
+    
+    searchpath = sep + 1;
+  } while (sep[0] != '\0');
+
+  if (path) free(path);
+  
+  return -1;
+}
+
 ikptr 
-ikrt_process(ikptr rvec, ikptr cmd, ikptr argv /*, ikpcb* pcb */){
+ikrt_process(ikptr rvec, ikptr env, ikptr cmd, ikptr argv /*, ikpcb* pcb */){
   int infds[2];
   int outfds[2];
   int errfds[2];
-  if(pipe(infds))  return ik_errno_to_code();
-  if(pipe(outfds)) return ik_errno_to_code();
-  if(pipe(errfds)) return ik_errno_to_code();
+  int search_p = ref(rvec, off_vector_data+0*wordsize) != false_object;
+  int stdin_fd = unfix(ref(rvec, off_vector_data+1*wordsize));
+  int stdout_fd = unfix(ref(rvec, off_vector_data+2*wordsize));
+  int stderr_fd = unfix(ref(rvec, off_vector_data+3*wordsize));
+
+  if(stdin_fd < 0 && pipe(infds))  return ik_errno_to_code();
+  if(stdout_fd < 0 && pipe(outfds)) return ik_errno_to_code();
+  if(stderr_fd < 0 && pipe(errfds)) return ik_errno_to_code();
   pid_t pid = fork();
   if(pid == 0){
     /* child */
-    if(close(infds[1]))  exit(1);
-    if(close(outfds[0])) exit(1);
-    if(close(errfds[0])) exit(1);
-    if(close(0))         exit(1);
-    if(dup(infds[0]) == -1)  exit(1);
-    if(close(1))         exit(1);
-    if(dup(outfds[1]) == -1) exit(1);
-    if(close(2))         exit(2);
-    if(dup(errfds[1]) == -1) exit(1);
-    execvp((char*)(long)(cmd+off_bytevector_data), list_to_vec(argv));
+    if (stdin_fd < 0){
+      if(close(infds[1]))  exit(1);
+      stdin_fd = infds[0];
+    }
+    if (stdout_fd < 0){
+      if(close(outfds[0])) exit(1);
+      stdout_fd = outfds[1];
+    }
+    if (stderr_fd < 0){
+        if(close(errfds[0])) exit(1);
+        stderr_fd = errfds[1];
+    }
+    if (stdin_fd != 0){
+      if(close(0))             exit(1);
+      if(dup(stdin_fd) == -1)  exit(1);
+    }
+    if (stdout_fd != 1){
+      if(close(1))             exit(1);
+      if(dup(stdout_fd) == -1) exit(1);
+    }
+    if (stderr_fd != 2){
+      if(close(2))             exit(2);
+      if(dup(stderr_fd) == -1) exit(1);
+    }
+    char *cmd_str = (char*)(long)(cmd+off_bytevector_data);
+    char **env_strs = env == false_object ? 0 : list_to_vec(env);
+    char **argv_strs = list_to_vec(argv);
+    if (env_strs && search_p)
+      execvpe_(cmd_str, argv_strs, env_strs);
+    else if (env_strs)
+      execve(cmd_str, argv_strs, env_strs);
+    else if (search_p)
+      execvp(cmd_str, argv_strs);
+    else
+      execv(cmd_str, argv_strs);
     fprintf(stderr, "failed to exec %s: %s\n", 
         (char*)(long)(cmd+off_bytevector_data),
         strerror(errno));
     exit(-1);
   } else if(pid > 0){
     /* parent */
-    close(infds[0]); /* ignore errors */
-    close(outfds[1]);
-    close(errfds[1]);
     ref(rvec,off_vector_data+0*wordsize) = fix(pid);
-    ref(rvec,off_vector_data+1*wordsize) = fix(infds[1]);
-    ref(rvec,off_vector_data+2*wordsize) = fix(outfds[0]);
-    ref(rvec,off_vector_data+3*wordsize) = fix(errfds[0]);
+
+    if (stdin_fd < 0) {
+      close(infds[0]); /* ignore errors */
+      ref(rvec,off_vector_data+1*wordsize) = fix(infds[1]);
+    }
+    if (stdout_fd < 0) {
+      close(outfds[1]);
+      ref(rvec,off_vector_data+2*wordsize) = fix(outfds[0]);
+    }
+    if (stderr_fd < 0) {
+      close(errfds[1]);
+      ref(rvec,off_vector_data+3*wordsize) = fix(errfds[0]);
+    }
     return rvec;
   } else {
     return ik_errno_to_code();