(define process-execute (let* ((pathname-strip-directory pathname-strip-directory) (c-string->allocated-pointer (foreign-lambda* c-pointer ((scheme-object o)) "char *ptr = malloc(C_header_size(o)); \n" "if (ptr != NULL) {\n" " C_memcpy(ptr, C_data_pointer(o), C_header_size(o)); \n" "}\n" "C_return(ptr);")) (free-buffer-array (lambda (buffer-array) (let ((size (pointer-vector-length buffer-array))) (do ((i 0 (fx+ i 1))) ((fx= i size)) (and-let* ((s (pointer-vector-ref buffer-array i))) (free s)))))) (copy&set-c-string! (lambda (buffer-array i s) ;; This avoids embedded NULs and appends a NUL, so "cs" is ;; safe to copy and use as-is in the pointer-vector. (let* ((cs (##sys#make-c-string s 'process-execute)) (csp (c-string->allocated-pointer cs))) (unless csp (error "Out of memory in process-execute")) (pointer-vector-set! buffer-array i csp)))) ;; TODO: Dynamically determine (arg-max (foreign-value "ARG_MAX" size_t)) (env-max (foreign-value "ENV_MAX" size_t)) (execvp (foreign-lambda int "C_execvp" c-string pointer-vector)) (execve (foreign-lambda int "C_execve" c-string pointer-vector pointer-vector))) (lambda (filename #!optional (arglist '()) envlist) (##sys#check-string filename 'process-execute) (##sys#check-list arglist 'process-execute) (when envlist (##sys#check-list envlist 'process-execute)) (let* ((stripped-filename (pathname-strip-directory filename)) (argcount (##sys#length arglist)) (envcount (and envlist (##sys#length envlist))) ;; NUL-terminated, so we must add one, and we also store ;; the filename in argv[0], so add another. (argbuf (make-pointer-vector (+ argcount 2) #f)) (envbuf (and envcount (make-pointer-vector (+ envcount 1) #f)))) ;; TODO: Check before making the vector? Doesn't matter much. (##sys#check-range argcount 0 arg-max 'process-execute) (when envlist (##sys#check-range envcount 0 env-max 'process-execute)) (handle-exceptions exn ;; Free to avoid memory leak, then reraise (begin (free-buffer-array argbuf) (when envbuf (free-buffer-array envbuf)) (signal exn)) (copy&set-c-string! argbuf 0 stripped-filename) (do ((al arglist (cdr al)) (i 1 (fx+ i 1)) ) ((or (null? al) (fx> i argcount))) ; Should coincide (copy&set-c-string! argbuf i (car al)) ) (do ((el (or envlist '()) (cdr el)) (i 0 (fx+ i 1)) ) ((or (null? el) (fx= i envcount))) ; Should coincide (copy&set-c-string! envbuf i (car el)) ) (let ((r (if envlist (execve filename argbuf envbuf) (execvp filename argbuf) )) ) (when (fx= r -1) (posix-error #:process-error 'process-execute "cannot execute process" filename) ) ))) ) ) )