From 10aef5a5a1c1e5c6f73d5d2a7aa7140bb263fc8e Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Mon, 30 Apr 2018 17:25:49 +0200 Subject: [PATCH 3/5] Refactor chicken.process so it no longer refers to chicken.posix Again, similar to the previous commit. Several small changes: - Renamed ##sys#process-wait (which holds the actual implementation of waiting for a process; common API uses this) to process-wait-impl. - Moved pip/buf, {open,close}-{input,output}-pipe, with-{input-from,output-to}-pipe and call-with-{input,output}-pipe to posix-common.scm as their implementations were identical in both posixwin.scm and posixunix.scm. - In preparation of potentially moving the "common" part of the process/process* implementations to posix-common.scm, unified the ##sys#shell-command interface so that it accepts a location in both posixunix (which ignores this argument) and posixwin (which uses it when raising an exception). Also dropped the ##sys# prefix on both it and ##sys#shell-command-arguments --- posix-common.scm | 102 ++++++++++++++++++++++-- posix.scm | 171 ++++++++++++++++++++-------------------- posixunix.scm | 234 +++++++++++++++++-------------------------------------- posixwin.scm | 222 ++++++++++++++++------------------------------------ types.db | 57 +++++++------- 5 files changed, 345 insertions(+), 441 deletions(-) diff --git a/posix-common.scm b/posix-common.scm index 3218d06d..af338db4 100644 --- a/posix-common.scm +++ b/posix-common.scm @@ -598,16 +598,17 @@ EOF (define current-process-id (foreign-lambda int "C_getpid")) -(define (process-sleep n) - (##sys#check-fixnum n 'process-sleep) - (##core#inline "C_i_process_sleep" n)) +(set! chicken.process#process-sleep + (lambda (n) + (##sys#check-fixnum n 'process-sleep) + (##core#inline "C_i_process_sleep" n))) -(define process-wait +(set! chicken.process#process-wait (lambda args - (let-optionals* args ([pid #f] [nohang #f]) - (let ([pid (or pid -1)]) + (let-optionals* args ((pid #f) (nohang #f)) + (let ((pid (or pid -1))) (##sys#check-fixnum pid 'process-wait) - (receive [epid enorm ecode] (##sys#process-wait pid nohang) + (receive (epid enorm ecode) (process-wait-impl pid nohang) (if (fx= epid -1) (posix-error #:process-error 'process-wait "waiting for child process failed" pid) (values epid enorm ecode) ) ) ) ) ) ) @@ -687,3 +688,90 @@ EOF nop loc))) (proc (##sys#make-c-string filename loc) argbuf envbuf)))))) + +;; Pipes: + +(define-foreign-variable _pipe_buf int "PIPE_BUF") +(set! chicken.process#pipe/buf _pipe_buf) + +(let () + (define (mode arg) (if (pair? arg) (##sys#slot arg 0) '###text)) + (define (badmode m) (##sys#error "illegal input/output mode specifier" m)) + (define (check loc cmd inp r) + (if (##sys#null-pointer? r) + (posix-error #:file-error loc "cannot open pipe" cmd) + (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class "(pipe)" 'stream))) + (##core#inline "C_set_file_ptr" port r) + port) ) ) + (set! chicken.process#open-input-pipe + (lambda (cmd . m) + (##sys#check-string cmd 'open-input-pipe) + (let ([m (mode m)]) + (check + 'open-input-pipe + cmd #t + (case m + ((#:text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd 'open-input-pipe))) + ((#:binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd 'open-input-pipe))) + (else (badmode m)) ) ) ) ) ) + (set! chicken.process#open-output-pipe + (lambda (cmd . m) + (##sys#check-string cmd 'open-output-pipe) + (let ((m (mode m))) + (check + 'open-output-pipe + cmd #f + (case m + ((#:text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd 'open-output-pipe))) + ((#:binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd 'open-output-pipe))) + (else (badmode m)) ) ) ) ) ) + (set! chicken.process#close-input-pipe + (lambda (port) + (##sys#check-input-port port #t 'close-input-pipe) + (let ((r (##core#inline "close_pipe" port))) + (when (eq? -1 r) + (posix-error #:file-error 'close-input-pipe "error while closing pipe" port)) + r) ) ) + (set! chicken.process#close-output-pipe + (lambda (port) + (##sys#check-output-port port #t 'close-output-pipe) + (let ((r (##core#inline "close_pipe" port))) + (when (eq? -1 r) + (posix-error #:file-error 'close-output-pipe "error while closing pipe" port)) + r) ) )) + +(set! chicken.process#with-input-from-pipe + (lambda (cmd thunk . mode) + (let ((p (apply chicken.process#open-input-pipe cmd mode))) + (fluid-let ((##sys#standard-input p)) + (call-with-values thunk + (lambda results + (chicken.process#close-input-pipe p) + (apply values results) ) ) ) ) ) ) + +(set! chicken.process#call-with-output-pipe + (lambda (cmd proc . mode) + (let ((p (apply chicken.process#open-output-pipe cmd mode))) + (call-with-values + (lambda () (proc p)) + (lambda results + (chicken.process#close-output-pipe p) + (apply values results) ) ) ) ) ) + +(set! chicken.process#call-with-input-pipe + (lambda (cmd proc . mode) + (let ([p (apply chicken.process#open-input-pipe cmd mode)]) + (call-with-values + (lambda () (proc p)) + (lambda results + (chicken.process#close-input-pipe p) + (apply values results) ) ) ) ) ) + +(set! chicken.process#with-output-to-pipe + (lambda (cmd thunk . mode) + (let ((p (apply chicken.process#open-output-pipe cmd mode))) + (fluid-let ((##sys#standard-output p)) + (call-with-values thunk + (lambda results + (chicken.process#close-output-pipe p) + (apply values results) ) ) ) ) ) ) diff --git a/posix.scm b/posix.scm index e58b6247..89bb0aff 100644 --- a/posix.scm +++ b/posix.scm @@ -182,21 +182,95 @@ ) ; chicken.time.posix +(module chicken.process + (qs system system* process-execute process-fork process-run + process-signal process-spawn process-wait call-with-input-pipe + call-with-output-pipe close-input-pipe close-output-pipe create-pipe + open-input-pipe open-output-pipe with-input-from-pipe + with-output-to-pipe process process* process-sleep pipe/buf + spawn/overlay spawn/wait spawn/nowait spawn/nowaito spawn/detach) + +(import scheme chicken.base chicken.fixnum chicken.platform) + + +;;; Execute a shell command: + +(define (system cmd) + (##sys#check-string cmd 'system) + (let ((r (##core#inline "C_execute_shell_command" cmd))) + (cond ((fx< r 0) + (##sys#update-errno) + (##sys#signal-hook #:process-error 'system "`system' invocation failed" cmd)) + (else r)))) + +;;; Like `system', but bombs on nonzero return code: + +(define (system* str) + (let ((n (system str))) + (unless (zero? n) + (##sys#error "shell invocation failed with non-zero return status" str n)))) + + +;;; Quote string for shell: + +(define (qs str #!optional (platform (software-version))) + (let* ((delim (if (eq? platform 'mingw32) #\" #\')) + (escaped (if (eq? platform 'mingw32) "\"\"" "'\\''")) + (escaped-parts + (map (lambda (c) + (cond + ((char=? c delim) escaped) + ((char=? c #\nul) + (error 'qs "NUL character can not be represented in shell string" str)) + (else (string c)))) + (string->list str)))) + (string-append + (string delim) + (apply string-append escaped-parts) + (string delim)))) + + +;; These are all set! inside the posix module +(define process-execute) +(define process-fork) +(define process-run) +(define process-signal) +(define process-spawn) +(define process-wait) + +(define call-with-input-pipe) +(define call-with-output-pipe) +(define close-input-pipe) +(define close-output-pipe) +(define create-pipe) +(define open-input-pipe) +(define open-output-pipe) +(define with-input-from-pipe) +(define with-output-to-pipe) + +(define process) +(define process*) +(define process-sleep) + +(define pipe/buf) + +(define spawn/overlay) +(define spawn/wait) +(define spawn/nowait) +(define spawn/nowaito) +(define spawn/detach) +) ; chicken.process + + ;; This module really does nothing. It is used to keep all the posix ;; stuff in one place, in a clean namespace. The included file will ;; set! values from the modules defined above. (module chicken.posix - (call-with-input-pipe call-with-output-pipe - change-directory* close-input-pipe - close-output-pipe create-pipe create-session + (change-directory* create-session current-effective-group-id current-effective-user-id current-effective-user-name current-group-id current-process-id current-user-id current-user-name - open-input-pipe open-output-pipe - parent-process-id - process process* process-execute process-fork - process-group-id process-run process-signal process-sleep - process-spawn process-wait + parent-process-id process-group-id set-alarm! set-root-directory! set-signal-handler! set-signal-mask! signal-handler signal-mask signal-mask! signal-masked? signal-unmask! signal/abrt signal/alrm signal/break signal/bus signal/chld @@ -204,9 +278,7 @@ signal/kill signal/pipe signal/prof signal/quit signal/segv signal/stop signal/term signal/trap signal/tstp signal/urg signal/usr1 signal/usr2 signal/vtalrm signal/winch signal/xcpu - signal/xfsz signals-list spawn/detach spawn/nowait - spawn/nowaito spawn/overlay spawn/wait user-information - with-input-from-pipe with-output-to-pipe) + signal/xfsz signals-list) (import scheme chicken.base @@ -274,83 +346,6 @@ ) ; chicken.errno -(module chicken.process - (qs system system* process-execute process-fork process-run - process-signal process-spawn process-wait call-with-input-pipe - call-with-output-pipe close-input-pipe close-output-pipe create-pipe - open-input-pipe open-output-pipe with-input-from-pipe - with-output-to-pipe process process* process-sleep pipe/buf - spawn/overlay spawn/wait spawn/nowait spawn/nowaito spawn/detach) - -(import scheme chicken.base chicken.fixnum chicken.platform) - - -;;; Execute a shell command: - -(define (system cmd) - (##sys#check-string cmd 'system) - (let ((r (##core#inline "C_execute_shell_command" cmd))) - (cond ((fx< r 0) - (##sys#update-errno) - (##sys#signal-hook #:process-error 'system "`system' invocation failed" cmd)) - (else r)))) - -;;; Like `system', but bombs on nonzero return code: - -(define (system* str) - (let ((n (system str))) - (unless (zero? n) - (##sys#error "shell invocation failed with non-zero return status" str n)))) - - -;;; Quote string for shell: - -(define (qs str #!optional (platform (software-version))) - (let* ((delim (if (eq? platform 'mingw32) #\" #\')) - (escaped (if (eq? platform 'mingw32) "\"\"" "'\\''")) - (escaped-parts - (map (lambda (c) - (cond - ((char=? c delim) escaped) - ((char=? c #\nul) - (error 'qs "NUL character can not be represented in shell string" str)) - (else (string c)))) - (string->list str)))) - (string-append - (string delim) - (apply string-append escaped-parts) - (string delim)))) - -(define process-execute chicken.posix#process-execute) -(define process-fork chicken.posix#process-fork) -(define process-run chicken.posix#process-run) -(define process-signal chicken.posix#process-signal) -(define process-spawn chicken.posix#process-spawn) -(define process-wait chicken.posix#process-wait) - -(define call-with-input-pipe chicken.posix#call-with-input-pipe) -(define call-with-output-pipe chicken.posix#call-with-output-pipe) -(define close-input-pipe chicken.posix#close-input-pipe) -(define close-output-pipe chicken.posix#close-output-pipe) -(define create-pipe chicken.posix#create-pipe) -(define open-input-pipe chicken.posix#open-input-pipe) -(define open-output-pipe chicken.posix#open-output-pipe) -(define with-input-from-pipe chicken.posix#with-input-from-pipe) -(define with-output-to-pipe chicken.posix#with-output-to-pipe) - -(define process chicken.posix#process) -(define process* chicken.posix#process*) -(define process-sleep chicken.posix#process-sleep) - -(define pipe/buf chicken.posix#pipe/buf) - -(define spawn/overlay chicken.posix#spawn/overlay) -(define spawn/wait chicken.posix#spawn/wait) -(define spawn/nowait chicken.posix#spawn/nowait) -(define spawn/nowaito chicken.posix#spawn/nowaito) -(define spawn/detach chicken.posix#spawn/detach) -) ; chicken.process - (module chicken.process.signal (set-signal-handler! set-signal-mask! signal-handler signal-mask signal-mask! signal-masked? signal-unmask! signal/abrt signal/alrm diff --git a/posixunix.scm b/posixunix.scm index 29cfab7e..2daade46 100644 --- a/posixunix.scm +++ b/posixunix.scm @@ -296,10 +296,6 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) ;;; Lo-level I/O: -(define-foreign-variable _pipe_buf int "PIPE_BUF") - -(define pipe/buf _pipe_buf) - (define-foreign-variable _f_dupfd int "F_DUPFD") (define-foreign-variable _f_getfd int "F_GETFD") (define-foreign-variable _f_setfd int "F_SETFD") @@ -324,11 +320,11 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) ;; Windows-only definitions (set! chicken.file.posix#open/noinherit 0) -(define spawn/overlay 0) -(define spawn/wait 0) -(define spawn/nowait 0) -(define spawn/nowaito 0) -(define spawn/detach 0) +(set! chicken.process#spawn/overlay 0) +(set! chicken.process#spawn/wait 0) +(set! chicken.process#spawn/nowait 0) +(set! chicken.process#spawn/nowaito 0) +(set! chicken.process#spawn/detach 0) (define-foreign-variable _s_isuid int "S_ISUID") (define-foreign-variable _s_isgid int "S_ISGID") @@ -462,101 +458,16 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (and fdsw (if (fixnum? fdsw) (and (memq fdsw wl) fdsw) wl)))))))))) -;;; Pipes: - -(define open-input-pipe) -(define open-output-pipe) -(define close-input-pipe) -(define close-output-pipe) - -(let () - (define (mode arg) (if (pair? arg) (##sys#slot arg 0) '###text)) - (define (badmode m) (##sys#error "illegal input/output mode specifier" m)) - (define (check loc cmd inp r) - (if (##sys#null-pointer? r) - (posix-error #:file-error loc "cannot open pipe" cmd) - (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class "(pipe)" 'stream))) - (##core#inline "C_set_file_ptr" port r) - port) ) ) - (set! open-input-pipe - (lambda (cmd . m) - (##sys#check-string cmd 'open-input-pipe) - (let ([m (mode m)]) - (check - 'open-input-pipe - cmd #t - (case m - ((#:text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd 'open-input-pipe))) - ((#:binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd 'open-input-pipe))) - (else (badmode m)) ) ) ) ) ) - (set! open-output-pipe - (lambda (cmd . m) - (##sys#check-string cmd 'open-output-pipe) - (let ((m (mode m))) - (check - 'open-output-pipe - cmd #f - (case m - ((#:text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd 'open-output-pipe))) - ((#:binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd 'open-output-pipe))) - (else (badmode m)) ) ) ) ) ) - (set! close-input-pipe - (lambda (port) - (##sys#check-input-port port #t 'close-input-pipe) - (let ((r (##core#inline "close_pipe" port))) - (when (eq? -1 r) - (posix-error #:file-error 'close-input-pipe "error while closing pipe" port)) - r) ) ) - (set! close-output-pipe - (lambda (port) - (##sys#check-output-port port #t 'close-output-pipe) - (let ((r (##core#inline "close_pipe" port))) - (when (eq? -1 r) - (posix-error #:file-error 'close-output-pipe "error while closing pipe" port)) - r) ) )) - -(define call-with-input-pipe - (lambda (cmd proc . mode) - (let ([p (apply open-input-pipe cmd mode)]) - (##sys#call-with-values - (lambda () (proc p)) - (lambda results - (close-input-pipe p) - (apply values results) ) ) ) ) ) - -(define call-with-output-pipe - (lambda (cmd proc . mode) - (let ([p (apply open-output-pipe cmd mode)]) - (##sys#call-with-values - (lambda () (proc p)) - (lambda results - (close-output-pipe p) - (apply values results) ) ) ) ) ) - -(define with-input-from-pipe - (lambda (cmd thunk . mode) - (let ([p (apply open-input-pipe cmd mode)]) - (fluid-let ((##sys#standard-input p)) - (##sys#call-with-values thunk - (lambda results - (close-input-pipe p) - (apply values results) ) ) ) ) ) ) -(define with-output-to-pipe - (lambda (cmd thunk . mode) - (let ([p (apply open-output-pipe cmd mode)]) - (fluid-let ((##sys#standard-output p)) - (##sys#call-with-values thunk - (lambda results - (close-output-pipe p) - (apply values results) ) ) ) ) ) ) +;;; Pipe primitive: (define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]") (define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]") -(define (create-pipe #!optional mode) - (when (fx< (##core#inline "C_pipe" #f) 0) - (posix-error #:file-error 'create-pipe "cannot create pipe") ) - (values _pipefd0 _pipefd1) ) +(set! chicken.process#create-pipe + (lambda (#!optional mode) + (when (fx< (##core#inline "C_pipe" #f) 0) + (posix-error #:file-error 'create-pipe "cannot create pipe") ) + (values _pipefd0 _pipefd1)) ) ;;; Signal processing: @@ -1137,7 +1048,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) ;;; Process handling: -(define process-fork +(set! chicken.process#process-fork (let ((fork (foreign-lambda int "C_fork"))) (lambda (#!optional thunk killothers) ;; flush all stdio streams before fork @@ -1156,61 +1067,64 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (exit 0))))) pid))))) -(define (process-execute filename #!optional (arglist '()) envlist exactf) - (call-with-exec-args - 'process-execute filename (lambda (x) x) arglist envlist - (lambda (prg argbuf envbuf) - (let ((r (if envbuf - (##core#inline "C_u_i_execve" prg argbuf envbuf) - (##core#inline "C_u_i_execvp" prg argbuf)))) - (when (fx= r -1) - (posix-error #:process-error 'process-execute "cannot execute process" filename)))))) +(set! chicken.process#process-execute + (lambda (filename #!optional (arglist '()) envlist exactf) + (call-with-exec-args + 'process-execute filename (lambda (x) x) arglist envlist + (lambda (prg argbuf envbuf) + (let ((r (if envbuf + (##core#inline "C_u_i_execve" prg argbuf envbuf) + (##core#inline "C_u_i_execvp" prg argbuf)))) + (when (fx= r -1) + (posix-error #:process-error 'process-execute "cannot execute process" filename))))))) (define-foreign-variable _wnohang int "WNOHANG") (define-foreign-variable _wait-status int "C_wait_status") -(define (##sys#process-wait pid nohang) - (let* ([res (##core#inline "C_waitpid" pid (if nohang _wnohang 0))] - [norm (##core#inline "C_WIFEXITED" _wait-status)] ) +(define (process-wait-impl pid nohang) + (let* ((res (##core#inline "C_waitpid" pid (if nohang _wnohang 0))) + (norm (##core#inline "C_WIFEXITED" _wait-status)) ) (if (and (fx= res -1) (fx= _errno _eintr)) (##sys#dispatch-interrupt - (lambda () (##sys#process-wait pid nohang))) + (lambda () (process-wait-impl pid nohang))) (values res norm - (cond [norm (##core#inline "C_WEXITSTATUS" _wait-status)] - [(##core#inline "C_WIFSIGNALED" _wait-status) - (##core#inline "C_WTERMSIG" _wait-status)] - [else (##core#inline "C_WSTOPSIG" _wait-status)] ) )) ) ) + (cond (norm (##core#inline "C_WEXITSTATUS" _wait-status)) + ((##core#inline "C_WIFSIGNALED" _wait-status) + (##core#inline "C_WTERMSIG" _wait-status)) + (else (##core#inline "C_WSTOPSIG" _wait-status)) ) )) ) ) (define parent-process-id (foreign-lambda int "C_getppid")) -(define process-signal +(set! chicken.process#process-signal (lambda (id . sig) - (let ([sig (if (pair? sig) (car sig) _sigterm)]) + (let ((sig (if (pair? sig) (car sig) _sigterm))) (##sys#check-fixnum id 'process-signal) (##sys#check-fixnum sig 'process-signal) - (let ([r (##core#inline "C_kill" id sig)]) + (let ((r (##core#inline "C_kill" id sig))) (when (fx= r -1) (posix-error #:process-error 'process-signal "could not send signal to process" id sig) ) ) ) ) ) -(define (##sys#shell-command) +(define (shell-command loc) (or (get-environment-variable "SHELL") "/bin/sh") ) -(define (##sys#shell-command-arguments cmdlin) +(define (shell-command-arguments cmdlin) (list "-c" cmdlin) ) -(define process-run +(set! chicken.process#process-run (lambda (f . args) - (let ([args (if (pair? args) (car args) #f)] - [pid (process-fork)] ) - (cond [(not (eq? 0 pid)) pid] - [args (process-execute f args)] - [else - (process-execute (##sys#shell-command) (##sys#shell-command-arguments f)) ] ) ) ) ) + (let ((args (if (pair? args) (car args) #f)) + (pid (chicken.process#process-fork)) ) + (cond ((not (eq? 0 pid)) pid) + (args (chicken.process#process-execute f args)) + (else + (chicken.process#process-execute + (shell-command 'process-run) + (shell-command-arguments f)) ) ) ) ) ) ;;; Run subprocess connected with pipes: -;; ##sys#process +;; process-impl ; loc caller procedure symbol ; cmd pathname or commandline ; args string-list or '() @@ -1227,26 +1141,26 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) ;FIXME process-execute, process-fork don't show parent caller -(define ##sys#process +(define process-impl (let ((replace-fd (lambda (loc fd stdfd) (unless (fx= stdfd fd) (chicken.file.posix#duplicate-fileno fd stdfd) (chicken.file.posix#file-close fd) ) )) ) - (let ( - [make-on-close - (lambda (loc pid clsvec idx idxa idxb) - (lambda () - (vector-set! clsvec idx #t) - (when (and (vector-ref clsvec idxa) (vector-ref clsvec idxb)) - (receive [_ flg cod] (##sys#process-wait pid #f) - (unless flg - (##sys#signal-hook #:process-error loc - "abnormal process exit" pid cod)) ) ) ) )] - [needed-pipe - (lambda (loc port) - (and port - (receive [i o] (create-pipe) (cons i o))) )] + (let ((make-on-close + (lambda (loc pid clsvec idx idxa idxb) + (lambda () + (vector-set! clsvec idx #t) + (when (and (vector-ref clsvec idxa) (vector-ref clsvec idxb)) + (receive (_ flg cod) (process-wait-impl pid #f) + (unless flg + (##sys#signal-hook #:process-error loc + "abnormal process exit" pid cod)) ) ) ) )) + (needed-pipe + (lambda (loc port) + (and port + (receive (i o) (chicken.process#create-pipe) + (cons i o))) )) [connect-parent (lambda (loc pipe port fd) (and port @@ -1271,12 +1185,12 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) [epipe (needed-pipe loc stderrf)]) (values ipipe (swapped-ends opipe) epipe - (process-fork + (chicken.process#process-fork (lambda () (connect-child loc opipe stdinf chicken.file.posix#fileno/stdin) (connect-child loc (swapped-ends ipipe) stdoutf chicken.file.posix#fileno/stdout) (connect-child loc (swapped-ends epipe) stderrf chicken.file.posix#fileno/stderr) - (process-execute cmd args env)))) ) ) )) + (chicken.process#process-execute cmd args env)))) ) ) )) [input-port (lambda (loc pid cmd pipe stdf stdfd on-close) (and-let* ([fd (connect-parent loc pipe stdf stdfd)]) @@ -1306,31 +1220,29 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) ;;; Run subprocess connected with pipes: -(define process) -(define process*) - +;; TODO: See if this can be moved to posix-common (let ((%process (lambda (loc err? cmd args env k) - (let ([chkstrlst - (lambda (lst) - (##sys#check-list lst loc) - (for-each (cut ##sys#check-string <> loc) lst) )]) + (let ((chkstrlst + (lambda (lst) + (##sys#check-list lst loc) + (for-each (cut ##sys#check-string <> loc) lst) ))) (##sys#check-string cmd loc) (if args (chkstrlst args) (begin - (set! args (##sys#shell-command-arguments cmd)) - (set! cmd (##sys#shell-command)) ) ) + (set! args (shell-command-arguments cmd)) + (set! cmd (shell-command loc)) ) ) (when env (check-environment-list env loc)) (##sys#call-with-values - (lambda () (##sys#process loc cmd args env #t #t err?)) + (lambda () (process-impl loc cmd args env #t #t err?)) k))))) - (set! process + (set! chicken.process#process (lambda (cmd #!optional args env exactf) (%process 'process #f cmd args env (lambda (i o p e) (values i o p))))) - (set! process* + (set! chicken.process#process* (lambda (cmd #!optional args env exactf) (%process 'process* #t cmd args env @@ -1348,4 +1260,4 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) ;;; unimplemented stuff: -(define-unimplemented process-spawn) +(set!-unimplemented chicken.process#process-spawn) diff --git a/posixwin.scm b/posixwin.scm index 382d8f77..caaa3e06 100644 --- a/posixwin.scm +++ b/posixwin.scm @@ -513,10 +513,6 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) ;;; Lo-level I/O: -(define-foreign-variable _pipe_buf int "PIPE_BUF") - -(define pipe/buf _pipe_buf) - (define-foreign-variable _o_noinherit int "O_NOINHERIT") (set! chicken.file.posix#open/noinherit _o_noinherit) @@ -607,109 +603,18 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (posix-error #:file-error 'file-mkstemp "cannot create temporary file" template)) (values fd tmpl))))))) -;;; Pipes: - -(define open-input-pipe) -(define open-output-pipe) -(define close-input-pipe) -(define close-output-pipe) - -(let () - (define (mode arg) (if (pair? arg) (##sys#slot arg 0) '###text)) - (define (badmode m) (##sys#error "illegal input/output mode specifier" m)) - (define (check cmd inp r) - (##sys#update-errno) - (if (##sys#null-pointer? r) - (##sys#signal-hook #:file-error "cannot open pipe" cmd) - (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class "(pipe)" 'stream))) - (##core#inline "C_set_file_ptr" port r) - port) ) ) - (set! open-input-pipe - (lambda (cmd . m) - (##sys#check-string cmd 'open-input-pipe) - (let ([m (mode m)]) - (check - cmd #t - (case m - ((###text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd 'open-input-pipe))) - ((###binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd 'open-input-pipe))) - (else (badmode m)) ) ) ) ) ) - (set! open-output-pipe - (lambda (cmd . m) - (##sys#check-string cmd 'open-output-pipe) - (let ((m (mode m))) - (check - cmd #f - (case m - ((###text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd 'open-output-pipe))) - ((###binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd 'open-output-pipe))) - (else (badmode m)) ) ) ) ) ) - (set! close-input-pipe - (lambda (port) - (##sys#check-input-port port #t 'close-input-pipe) - (let ((r (##core#inline "close_pipe" port))) - (##sys#update-errno) - (when (eq? -1 r) - (##sys#signal-hook #:file-error 'close-input-pipe "error while closing pipe" port) ) - r))) - (set! close-output-pipe - (lambda (port) - (##sys#check-output-port port #t 'close-output-pipe) - (let ((r (##core#inline "close_pipe" port))) - (##sys#update-errno) - (when (eq? -1 r) - (##sys#signal-hook #:file-error 'close-output-pipe "error while closing pipe" port) ) - r)))) - -(define call-with-input-pipe - (lambda (cmd proc . mode) - (let ([p (apply open-input-pipe cmd mode)]) - (##sys#call-with-values - (lambda () (proc p)) - (lambda results - (close-input-pipe p) - (apply values results) ) ) ) ) ) - -(define call-with-output-pipe - (lambda (cmd proc . mode) - (let ([p (apply open-output-pipe cmd mode)]) - (##sys#call-with-values - (lambda () (proc p)) - (lambda results - (close-output-pipe p) - (apply values results) ) ) ) ) ) - -(define with-input-from-pipe - (lambda (cmd thunk . mode) - (let ([p (apply open-input-pipe cmd mode)]) - (fluid-let ((##sys#standard-input p)) - (##sys#call-with-values - thunk - (lambda results - (close-input-pipe p) - (apply values results) ) ) ) ) ) ) - -(define with-output-to-pipe - (lambda (cmd thunk . mode) - (let ([p (apply open-output-pipe cmd mode)]) - (fluid-let ((##sys#standard-output p)) - (##sys#call-with-values - thunk - (lambda results - (close-output-pipe p) - (apply values results) ) ) ) ) ) ) - - ;;; Pipe primitive: (define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]") (define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]") -(define (create-pipe #!optional (mode (fxior chicken.file.posix#open/binary chicken.file.posix#open/noinherit))) - (when (fx< (##core#inline "C_pipe" #f mode) 0) - (##sys#update-errno) - (##sys#signal-hook #:file-error 'create-pipe "cannot create pipe") ) - (values _pipefd0 _pipefd1) ) +(set! chicken.process#create-pipe + (lambda (#!optional (mode (fxior chicken.file.posix#open/binary + chicken.file.posix#open/noinherit))) + (when (fx< (##core#inline "C_pipe" #f mode) 0) + (##sys#update-errno) + (##sys#signal-hook #:file-error 'create-pipe "cannot create pipe") ) + (values _pipefd0 _pipefd1) ) ) ;;; Signal processing: @@ -788,11 +693,11 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (define-foreign-variable _p_nowaito int "P_NOWAITO") (define-foreign-variable _p_detach int "P_DETACH") -(define spawn/overlay _p_overlay) -(define spawn/wait _p_wait) -(define spawn/nowait _p_nowait) -(define spawn/nowaito _p_nowaito) -(define spawn/detach _p_detach) +(set! chicken.process#spawn/overlay _p_overlay) +(set! chicken.process#spawn/wait _p_wait) +(set! chicken.process#spawn/nowait _p_nowait) +(set! chicken.process#spawn/nowaito _p_nowaito) +(set! chicken.process#spawn/detach _p_detach) ; Windows uses a commandline style for process arguments. Thus any ; arguments with embedded whitespace will parse incorrectly. Must @@ -811,51 +716,57 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (lambda (str) (if (needs-quoting? str) (string-append "\"" str "\"") str)))) -(define (process-execute filename #!optional (arglist '()) envlist exactf) - (let ((argconv (if exactf (lambda (x) x) quote-arg-string))) - (call-with-exec-args - 'process-execute filename argconv arglist envlist - (lambda (prg argbuf envbuf) - (##core#inline "C_flushall") - (let ((r (if envbuf - (##core#inline "C_u_i_execve" prg argbuf envbuf) - (##core#inline "C_u_i_execvp" prg argbuf)))) - (when (fx= r -1) - (posix-error #:process-error 'process-execute "cannot execute process" filename))))))) - -(define (process-spawn mode filename #!optional (arglist '()) envlist exactf) - (let ((argconv (if exactf (lambda (x) x) quote-arg-string))) - (##sys#check-fixnum mode 'process-spawn) - (call-with-exec-args - 'process-spawn filename argconv arglist envlist - (lambda (prg argbuf envbuf) - (##core#inline "C_flushall") - (let ((r (if envbuf - (##core#inline "C_u_i_spawnvpe" mode prg argbuf envbuf) - (##core#inline "C_u_i_spawnvp" mode prg argbuf)))) - (when (fx= r -1) - (posix-error #:process-error 'process-spawn "cannot spawn process" filename)) - r))))) +(set! chicken.process#process-execute + (lambda (filename #!optional (arglist '()) envlist exactf) + (let ((argconv (if exactf (lambda (x) x) quote-arg-string))) + (call-with-exec-args + 'process-execute filename argconv arglist envlist + (lambda (prg argbuf envbuf) + (##core#inline "C_flushall") + (let ((r (if envbuf + (##core#inline "C_u_i_execve" prg argbuf envbuf) + (##core#inline "C_u_i_execvp" prg argbuf)))) + (when (fx= r -1) + (posix-error #:process-error 'process-execute "cannot execute process" filename)))))))) + +(set! chicken.process#process-spawn + (lambda (mode filename #!optional (arglist '()) envlist exactf) + (let ((argconv (if exactf (lambda (x) x) quote-arg-string))) + (##sys#check-fixnum mode 'process-spawn) + (call-with-exec-args + 'process-spawn filename argconv arglist envlist + (lambda (prg argbuf envbuf) + (##core#inline "C_flushall") + (let ((r (if envbuf + (##core#inline "C_u_i_spawnvpe" mode prg argbuf envbuf) + (##core#inline "C_u_i_spawnvp" mode prg argbuf)))) + (when (fx= r -1) + (posix-error #:process-error 'process-spawn "cannot spawn process" filename)) + r)))))) (define-foreign-variable _shlcmd c-string "C_shlcmd") -(define (##sys#shell-command) +(define (shell-command loc) (or (get-environment-variable "COMSPEC") (if (##core#inline "C_get_shlcmd") _shlcmd (begin (##sys#update-errno) - (##sys#error '##sys#shell-command "cannot retrieve system directory") ) ) ) ) + (##sys#error loc "cannot retrieve system directory") ) ) ) ) -(define (##sys#shell-command-arguments cmdlin) +(define (shell-command-arguments cmdlin) (list "/c" cmdlin) ) -(define process-run +(set! chicken.process#process-run (lambda (f . args) - (let ([args (if (pair? args) (car args) #f)]) + (let ((args (if (pair? args) (car args) #f))) (if args - (process-spawn spawn/nowait f args) - (process-spawn spawn/nowait (##sys#shell-command) (##sys#shell-command-arguments f)) ) ) ) ) + (chicken.process#process-spawn + chicken.process#spawn/nowait f args) + (chicken.process#process-spawn + chicken.process#spawn/nowait + (shell-command 'process-run) + (shell-command-arguments f)) ) ) ) ) ;;; Run subprocess connected with pipes: (define-foreign-variable _rdbuf char "C_rdbuf") @@ -863,7 +774,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (define-foreign-variable _rd1 int "C_rd1_") ; from original by Mejedi -;; ##sys#process +;; process-impl ; loc caller procedure symbol ; cmd pathname or commandline ; args string-list or '() @@ -875,7 +786,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) ; (values stdin-input-port? stdout-output-port? pid stderr-input-port?) ; where stdin-input-port?, etc. is a port or #f, indicating no port created. -(define ##sys#process +(define process-impl ;; XXX TODO: When environment is implemented, check for embedded NUL bytes! (let ([c-process (foreign-lambda bool "C_process" c-string c-string c-pointer @@ -909,37 +820,36 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (##sys#update-errno) (##sys#signal-hook #:process-error loc "cannot execute process" cmdlin))) ) ) ) ) ) ) -(define process) -(define process*) - -(let ([%process +;; TODO: See if this can be moved to posix-common +(let ((%process (lambda (loc err? cmd args env exactf) - (let ([chkstrlst + (let ((chkstrlst (lambda (lst) (##sys#check-list lst loc) - (for-each (cut ##sys#check-string <> loc) lst) )]) + (for-each (cut ##sys#check-string <> loc) lst) ))) (##sys#check-string cmd loc) (if args (chkstrlst args) (begin (set! exactf #t) - (set! args (##sys#shell-command-arguments cmd)) - (set! cmd (##sys#shell-command)) ) ) + (set! args (shell-command-arguments cmd)) + (set! cmd (shell-command loc)) ) ) (when env (check-environment-list env loc)) - (receive [in out pid err] (##sys#process loc cmd args env #t #t err? exactf) + (receive (in out pid err) + (process-impl loc cmd args env #t #t err? exactf) (if err? (values in out pid err) - (values in out pid) ) ) ) )] ) - (set! process + (values in out pid) ) ) ) )) ) + (set! chicken.process#process (lambda (cmd #!optional args env exactf) (%process 'process #f cmd args env exactf) )) - (set! process* + (set! chicken.process#process* (lambda (cmd #!optional args env exactf) (%process 'process* #t cmd args env exactf) )) ) (define-foreign-variable _exstatus int "C_exstatus") -(define (##sys#process-wait pid nohang) +(define (process-wait-impl pid nohang) (if (##core#inline "C_process_wait" pid nohang) (values pid #t _exstatus) (values -1 #f #f) ) ) @@ -977,9 +887,9 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (set!-unimplemented chicken.file.posix#file-truncate) (set!-unimplemented chicken.file.posix#file-unlock) (define-unimplemented parent-process-id) -(define-unimplemented process-fork) +(set!-unimplemented chicken.process#process-fork) (define-unimplemented process-group-id) -(define-unimplemented process-signal) +(set!-unimplemented chicken.process#process-signal) (set!-unimplemented chicken.file.posix#read-symbolic-link) (define-unimplemented set-alarm!) (define-unimplemented set-group-id!) diff --git a/types.db b/types.db index 79044d7a..ff18fa4f 100644 --- a/types.db +++ b/types.db @@ -2035,12 +2035,7 @@ ;; posix -(chicken.posix#call-with-input-pipe (#(procedure #:enforce) chicken.posix#call-with-input-pipe (string (procedure (input-port) . *) #!optional symbol) . *)) -(chicken.posix#call-with-output-pipe (#(procedure #:enforce) chicken.posix#call-with-output-pipe (string (procedure (input-port) . *) #!optional symbol) . *)) (chicken.posix#change-directory* (#(procedure #:clean #:enforce) chicken.posix#change-directory* (fixnum) fixnum)) -(chicken.posix#close-input-pipe (#(procedure #:clean #:enforce) chicken.posix#close-input-pipe (input-port) fixnum)) -(chicken.posix#close-output-pipe (#(procedure #:clean #:enforce) chicken.posix#close-output-pipe (output-port) fixnum)) -(chicken.posix#create-pipe (procedure chicken.posix#create-pipe (#!optional fixnum) fixnum fixnum)) (chicken.posix#create-session (#(procedure #:clean) chicken.posix#create-session () fixnum)) (chicken.posix#current-effective-group-id (#(procedure #:clean) chicken.posix#current-effective-group-id () fixnum)) @@ -2050,24 +2045,9 @@ (chicken.posix#current-process-id (#(procedure #:clean) chicken.posix#current-process-id () fixnum)) (chicken.posix#current-user-id (#(procedure #:clean) chicken.posix#current-user-id () fixnum)) (chicken.posix#current-user-name (#(procedure #:clean) chicken.posix#current-user-name () string)) -(chicken.posix#open-input-pipe (#(procedure #:clean #:enforce) chicken.posix#open-input-pipe (string #!optional symbol) input-port)) -(chicken.posix#open-output-pipe (#(procedure #:clean #:enforce) chicken.posix#open-output-pipe (string #!optional symbol) output-port)) (chicken.posix#parent-process-id (#(procedure #:clean) chicken.posix#parent-process-id () fixnum)) -(chicken.posix#pipe/buf fixnum) -(chicken.posix#process (#(procedure #:clean #:enforce) chicken.posix#process (string #!optional (list-of string) (list-of (pair string string)) boolean) input-port output-port fixnum)) -(chicken.posix#process* (#(procedure #:clean #:enforce) chicken.posix#process* (string #!optional (list-of string) (list-of (pair string string)) boolean) input-port output-port fixnum *)) - -(chicken.posix#process-execute - (#(procedure #:clean #:enforce) chicken.posix#process-execute (string #!optional (list-of string) (list-of (pair string string)) fixnum) noreturn)) - -(chicken.posix#process-fork (#(procedure #:enforce) chicken.posix#process-fork (#!optional (or (procedure () . *) false) *) fixnum)) (chicken.posix#process-group-id (#(procedure #:clean #:enforce) chicken.posix#process-group-id () fixnum)) -(chicken.posix#process-run (#(procedure #:clean #:enforce) chicken.posix#process-run (string #!optional (list-of string)) fixnum)) -(chicken.posix#process-signal (#(procedure #:clean #:enforce) chicken.posix#process-signal (fixnum #!optional fixnum) undefined)) -(chicken.posix#process-spawn - (#(procedure #:clean #:enforce) chicken.posix#process-spawn (fixnum string #!optional (list-of string) (list-of (pair string string)) boolean) fixnum)) -(chicken.posix#process-wait (#(procedure #:clean #:enforce) chicken.posix#process-wait (#!optional fixnum *) fixnum fixnum fixnum)) (chicken.posix#set-alarm! (#(procedure #:clean #:enforce) chicken.posix#set-alarm! (integer) integer)) (chicken.posix#set-root-directory! (#(procedure #:clean #:enforce) chicken.posix#set-root-directory! (string) undefined)) (chicken.posix#set-signal-handler! (#(procedure #:clean #:enforce) chicken.posix#set-signal-handler! (fixnum (or false (procedure (fixnum) . *))) undefined)) @@ -2104,21 +2084,40 @@ (chicken.posix#signal/xcpu fixnum) (chicken.posix#signal/xfsz fixnum) (chicken.posix#signals-list list) -(chicken.posix#spawn/overlay fixnum) -(chicken.posix#spawn/wait fixnum) -(chicken.posix#spawn/nowait fixnum) -(chicken.posix#spawn/nowaito fixnum) -(chicken.posix#spawn/detach fixnum) -(chicken.posix#process-sleep (#(procedure #:clean #:enforce) chicken.posix#process-sleep (fixnum) fixnum)) (chicken.posix#user-information (#(procedure #:clean #:enforce) chicken.posix#user-information ((or string fixnum) #!optional *) *)) -(chicken.posix#with-input-from-pipe (#(procedure #:enforce) chicken.posix#with-input-from-pipe (string (procedure () . *) #!optional symbol) . *)) -(chicken.posix#with-output-to-pipe (#(procedure #:enforce) chicken.posix#with-output-to-pipe (string (procedure () . *) #!optional symbol) . *)) ;; process +(chicken.process#process-execute + (#(procedure #:clean #:enforce) chicken.process#process-execute (string #!optional (list-of string) (list-of (pair string string)) fixnum) noreturn)) +(chicken.process#process-fork (#(procedure #:enforce) chicken.process#process-fork (#!optional (or (procedure () . *) false) *) fixnum)) +(chicken.process#qs (#(procedure #:clean #:enforce) chicken.process#qs (string) string)) +(chicken.process#process-run (#(procedure #:clean #:enforce) chicken.process#process-run (string #!optional (list-of string)) fixnum)) +(chicken.process#process-signal (#(procedure #:clean #:enforce) chicken.process#process-signal (fixnum #!optional fixnum) undefined)) +(chicken.process#process-spawn + (#(procedure #:clean #:enforce) chicken.process#process-spawn (fixnum string #!optional (list-of string) (list-of (pair string string)) boolean) fixnum)) (chicken.process#system (#(procedure #:clean #:enforce) chicken.process#system (string) fixnum)) (chicken.process#system* (#(procedure #:clean #:enforce) chicken.process#system* (string #!rest) undefined)) -(chicken.process#qs (#(procedure #:clean #:enforce) chicken.process#qs (string) string)) +(chicken.process#process (#(procedure #:clean #:enforce) chicken.process#process (string #!optional (list-of string) (list-of (pair string string)) boolean) input-port output-port fixnum)) +(chicken.process#process* (#(procedure #:clean #:enforce) chicken.process#process* (string #!optional (list-of string) (list-of (pair string string)) boolean) input-port output-port fixnum *)) +(chicken.process#process-wait (#(procedure #:clean #:enforce) chicken.process#process-wait (#!optional fixnum *) fixnum fixnum fixnum)) +(chicken.process#process-sleep (#(procedure #:clean #:enforce) chicken.process#process-sleep (fixnum) fixnum)) +(chicken.process#call-with-input-pipe (#(procedure #:enforce) chicken.process#call-with-input-pipe (string (procedure (input-port) . *) #!optional symbol) . *)) +(chicken.process#call-with-output-pipe (#(procedure #:enforce) chicken.process#call-with-output-pipe (string (procedure (input-port) . *) #!optional symbol) . *)) +(chicken.process#close-input-pipe (#(procedure #:clean #:enforce) chicken.process#close-input-pipe (input-port) fixnum)) +(chicken.process#close-output-pipe (#(procedure #:clean #:enforce) chicken.process#close-output-pipe (output-port) fixnum)) +(chicken.process#create-pipe (procedure chicken.process#create-pipe (#!optional fixnum) fixnum fixnum)) +(chicken.process#open-input-pipe (#(procedure #:clean #:enforce) chicken.process#open-input-pipe (string #!optional symbol) input-port)) +(chicken.process#open-output-pipe (#(procedure #:clean #:enforce) chicken.process#open-output-pipe (string #!optional symbol) output-port)) +(chicken.process#with-input-from-pipe (#(procedure #:enforce) chicken.process#with-input-from-pipe (string (procedure () . *) #!optional symbol) . *)) +(chicken.process#with-output-to-pipe (#(procedure #:enforce) chicken.process#with-output-to-pipe (string (procedure () . *) #!optional symbol) . *)) + +(chicken.process#pipe/buf fixnum) +(chicken.process#spawn/overlay fixnum) +(chicken.process#spawn/wait fixnum) +(chicken.process#spawn/nowait fixnum) +(chicken.process#spawn/nowaito fixnum) +(chicken.process#spawn/detach fixnum) ;; sort -- 2.11.0