~ chicken-core (chicken-5) 65ee25d80a374905ffd36807dfa914d125a2a3dc
commit 65ee25d80a374905ffd36807dfa914d125a2a3dc
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Feb 3 15:41:09 2025 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Feb 5 18:57:32 2025 +0100
use process-objects; more wchar_t related changes in posixwin
diff --git a/NEWS b/NEWS
index 61df9e40..a2832681 100644
--- a/NEWS
+++ b/NEWS
@@ -14,6 +14,11 @@
supported are currently UTF-8 (the default) and Latin-1 (ISO-8859-1).
- `file-read', `file-write', 'set-pseudo-random-seed!' and `random-bytes'
require a bytevector argument and do not accept strings.
+ - `process-fork', `process-run', `process' and `process*' return now
+ a process-object instead of a PID, use process record accessors to
+ retrieve exit-status and input/output ports. `process-wait' and
+ `process-signal' accept either a PID or a process object as
+ argument.
- File-locking operations in the (chicken file posix) module now use the
flock(2) system call, operator over whole files, are thread-safe and
use a simpler interface. `file-test-lock' has been removed.
diff --git a/manual/Module (chicken process) b/manual/Module (chicken process)
index bcb433c1..d3cbbe73 100644
--- a/manual/Module (chicken process)
+++ b/manual/Module (chicken process)
@@ -5,10 +5,11 @@
This module offers procedures for interacting with subprocesses.
-* New in CHICKEN 5.4.0: Errors caused by underlying C calls that
- change errno will produce a condition object with an {{errno}}
- property, which can be accessed with
- {{(get-condition-property <the-condition-object> 'exn 'errno)}}.
+Note:
+Errors caused by underlying C calls that
+change errno will produce a condition object with an {{errno}}
+property, which can be accessed with
+{{(get-condition-property <the-condition-object> 'exn 'errno)}}.
=== Processes
@@ -40,8 +41,9 @@ quotes. When {{#t}} no such wrapping occurs.
<procedure>(process-fork [THUNK [KILLOTHERS?]])</procedure>
Creates a new child process with the UNIX system call
-{{fork()}}. Returns either the PID of the child process or 0. If
-{{THUNK}} is given, then the child process calls it as a procedure
+{{fork()}}. In the parent process this procedure returns a process-object representing the child process
+and in the child process {{process-fork}} returns {{#f}}.
+If {{THUNK}} is given, then the child process calls it as a procedure
with no arguments and terminates. If {{THUNK}} is given and the
optional argument {{KILLOTHERS?}} is true, then kill all other
existing threads in the child process, leaving only the current thread
@@ -55,7 +57,7 @@ procedure is unimplemented and will raise an error.
<procedure>(process-run COMMANDLINE)</procedure><br>
<procedure>(process-run COMMAND ARGUMENT-LIST)</procedure>
-Creates a new child process. The PID of the new process is returned.
+Creates a new child process. The process object representing the new process is returned.
* The single parameter version passes the {{COMMANDLINE}} to the
system shell, so usual argument expansion can take place. Be careful
@@ -67,9 +69,10 @@ single-parameter version because of its better safety.
==== process-signal
-<procedure>(process-signal PID [SIGNAL])</procedure>
+<procedure>(process-signal PROCESS [SIGNAL])</procedure>
-Sends {{SIGNAL}} to the process with the id {{PID}} using the
+Sends {{SIGNAL}} to the process with the integer id or prcoess
+object {{PROCESS}} using the
UNIX system call {{kill()}}. {{SIGNAL}} defaults to the value
of the variable {{signal/term}}.
@@ -90,8 +93,7 @@ argument strings. When {{#t}} quote-wrapping is not performed.
Returns:
* the exit status when synchronous
-* the PID when asynchronous
-* -1 when failure
+* a process object when asynchronous
'''NOTE''': On all Unix-like builds (all except native MingW-based
Windows platforms), this procedure is unimplemented and will raise an
@@ -114,11 +116,12 @@ semantics of {{process-spawn}}:
==== process-wait
-<procedure>(process-wait [PID [NOHANG]])</procedure>
+<procedure>(process-wait [PROCESS [NOHANG]])</procedure>
-Suspends the current process until the child process with
-the id {{PID}} has terminated using the UNIX system call
-{{waitpid()}}. If {{PID}} is not given, then this procedure
+Suspends the current process until the child process identifier by {{PROCESS}},
+which should be a process object or an integer process id (pid),
+has terminated using the UNIX system call
+{{waitpid()}}. If {{PROCESS}} is not given, then this procedure
waits for any child process. If {{NOHANG}} is given and not
{{#f}} then the current process is not suspended. This procedure
returns three values:
@@ -130,6 +133,9 @@ returns three values:
Note that suspending the current process implies that all threads
are suspended as well.
+The exit status and the flag indicating whether the process returned normally
+are also stored in {{PROCESS}}, when given to be retrieved later, if desired.
+
On Windows, {{process-wait}} always returns {{#t}} for a terminated
process and only the exit status is available. (Windows does not
provide signals as an interprocess communication method.)
@@ -149,16 +155,9 @@ if a signal occurred.
<procedure>(process COMMANDLINE)</procedure><br>
<procedure>(process COMMAND ARGUMENT-LIST [ENVIRONMENT-ALIST ENCODING])</procedure>
-Creates a subprocess and returns three values: an input port from
-which data written by the sub-process can be read, an output port from
-which any data written to will be received as input in the sub-process
-and the process-id of the started sub-process. Blocking reads and writes
-to or from the ports returned by {{process}} only block the current
-thread, not other threads executing concurrently.
-
-Standard error for the subprocess is linked up to the current
-process's standard error (see {{process*}} if you want to reify
-its standard error into a separate port).
+Creates a subprocess and returns a process object, with the input-, output- and
+error ports stored in the object, which can be accessed using accessors described
+below.
* The single parameter version passes the string {{COMMANDLINE}} to the host-system's shell that
is invoked as a subprocess.
@@ -175,7 +174,10 @@ Not using the shell may be preferrable for security reasons.
Once both the input- and output ports are closed, an implicit
{{waitpid(3)}} is done to wait for the subprocess to finish or to reap
a subprocess that has terminated. If the subprocess has not finished,
-waiting for it will necessarily block all executing threads.
+waiting for it will necessarily block all executing threads. The exit status
+and whether the process exitted normally will be stored in the returned
+process object to be retrieved later by the accessors described below,
+if so desired.
==== process*
@@ -188,6 +190,39 @@ which any data written to will be received as input in the sub-process,
the process-id of the started sub-process, and an input port from
which data written by the sub-process to {{stderr}} can be read.
+==== process?
+==== process-id
+==== process-exit-status
+==== process-returned-normally?
+==== process-input-port
+==== process-output-port
+==== process-error-port
+
+<procedure>(process? X)</procedure>
+
+Returns a boolean indicating whether {{X}} is a process object.
+
+<procedure>(process-id PROCESS)</procedure>
+<procedure>(process-exit-status PROCESS)</procedure>
+<procedure>(process-returned-normally? PROCESS)</procedure>
+<procedure>(process-input-port PROCESS)</procedure>
+<procedure>(process-output-port PROCESS)</procedure>
+<procedure>(process-error-port PROCESS)</procedure>
+
+Accessors for process-object attributes. The ports values are only
+defined for processes created with {{process}} or {{process*}} and represent
+the input port from
+which data written by the sub-process can be read, the output port from
+which any data written to will be received as input in the sub-process
+and the error port where to which the sub-process directs its error output.
+Blocking reads and writes
+to or from the ports returned by {{process}} only block the current
+thread, not other threads executing concurrently.
+
+Standard error for the subprocess is linked up to the current
+process's standard error (see {{process*}} if you want to reify
+its standard error into a separate port).
+
=== Shell commands
The commands below are all string-based. This means you have to be
@@ -221,7 +256,7 @@ failed, an exception is raised. Otherwise the return status of the
subprocess is returned unaltered.
-On a UNIX system, that value is the raw return value of waitpid(2), which contains signal, core dump and exit status. It is 0 on success. To pull out the signal number or exit status portably requires POSIX calls, but in a pinch you can use something like this:
+On a UNIX system, that value is the raw return value of waitpid(2), which contains signal, core dump and exit status. It is 0 on success. To pull out the signal number or exit status portably requires POSIX calls, but in a pinch you can use something like this:
<enscript highlight='scheme'>
;; Returns two values: #t if the process exited normally or #f otherwise;
diff --git a/posix-common.scm b/posix-common.scm
index 7ea2cf56..2935ff3c 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -677,6 +677,36 @@ EOF
;;; Processes
+(define children '())
+
+(define-record process
+ id returned-normally? input-port output-port error-port exit-status)
+
+(define (get-pid x #!optional default)
+ (cond ((fixnum? x) x)
+ ((process? x) (process-id x))
+ (else default)))
+
+(define (register-pid pid)
+ (let ((p (make-process pid #f #f #f #f #f)))
+ (set! children (cons (cons pid p) children))
+ p))
+
+(define (drop-child pid)
+ (set! children
+ (let rec ((cs children))
+ (cond ((null? cs) '())
+ ((eq? pid (caar cs)) (cdr cs))
+ (else (rec (cdr cs)))))))
+
+(set! chicken.process#process? process?)
+(set! chicken.process#process-id process-id)
+(set! chicken.process#process-exit-status process-exit-status)
+(set! chicken.process#process-returned-normally? process-returned-normally?)
+(set! chicken.process#process-input-port process-input-port)
+(set! chicken.process#process-output-port process-output-port)
+(set! chicken.process#process-error-port process-error-port)
+
(set! chicken.process#process-sleep
(lambda (n)
(##sys#check-fixnum n 'process-sleep)
@@ -684,54 +714,60 @@ EOF
(set! chicken.process#process-wait
(lambda args
- (let-optionals* args ((pid #f) (nohang #f))
- (let ((pid (or pid -1)))
- (##sys#check-fixnum pid 'process-wait)
- (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) ) ) ) ) ) )
+ (let-optionals* args ((proc #f) (nohang #f))
+ (if (and proc (process? proc) (process-exit-status proc))
+ (values (process-id proc)
+ (process-returned-normally? proc)
+ (process-exit-status proc))
+ (let ((pid (get-pid proc -1)))
+ (##sys#check-fixnum pid 'process-wait)
+ (receive (epid enorm ecode) (process-wait-impl pid nohang)
+ (unless proc
+ (let ((a (assq pid children)))
+ (when a
+ (set! proc (cdr a))
+ (drop-child pid))))
+ (when (process? proc)
+ (process-returned-normally?-set! proc enorm)
+ (process-exit-status-set! proc ecode))
+ (if (fx= epid -1)
+ (posix-error #:process-error 'process-wait
+ "waiting for child process failed" pid)
+ (values epid enorm ecode) ) ) )) ) ) )
;; This can construct argv or envp for process-execute or process-run
(define list->c-string-buffer
- (let ((c-string->allocated-pointer
- (foreign-lambda* c-pointer ((scheme-object o))
- "char *ptr = C_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);")))
(lambda (string-list convert loc)
(##sys#check-list string-list loc)
(let* ((string-count (##sys#length string-list))
- ;; NUL-terminated, so we must add one
- (buffer (make-pointer-vector (add1 string-count) #f)))
+ ;; NUL-terminated, so we must add one
+ (buffer (make-pointer-vector (add1 string-count) #f)))
- (handle-exceptions exn
- ;; Free to avoid memory leak, then reraise
- (begin (free-c-string-buffer buffer) (signal exn))
+ (handle-exceptions exn
+ ;; Free to avoid memory leak, then reraise
+ (begin (free-c-string-buffer buffer) (signal exn))
- (do ((sl string-list (cdr sl))
- (i 0 (fx+ i 1)))
- ((or (null? sl) (fx= i string-count))) ; Should coincide
+ (do ((sl string-list (cdr sl))
+ (i 0 (fx+ i 1)))
+ ((or (null? sl) (fx= i string-count))) ; Should coincide
- (##sys#check-string (car sl) loc)
- ;; 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 (convert (car sl)) loc))
- (csp (c-string->allocated-pointer cs)))
- (unless csp (error loc "Out of memory"))
- (pointer-vector-set! buffer i csp)))
+ (##sys#check-string (car sl) loc)
+ ;; 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 (convert (car sl)) loc))
+ (csp (c-string->allocated-pointer cs)))
+ (unless csp (error loc "Out of memory"))
+ (pointer-vector-set! buffer i csp)))
- buffer)))))
+ buffer))))
(define (free-c-string-buffer buffer-array)
(let ((size (pointer-vector-length buffer-array)))
(do ((i 0 (fx+ i 1)))
- ((fx= i size))
+ ((fx= i size))
(and-let* ((s (pointer-vector-ref buffer-array i)))
- (free s)))))
+ (free s)))))
;; Environments are represented as string->string association lists
(define (check-environment-list lst loc)
diff --git a/posix.scm b/posix.scm
index c49906bc..43069da4 100644
--- a/posix.scm
+++ b/posix.scm
@@ -187,7 +187,9 @@
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)
+ spawn/overlay spawn/wait spawn/nowait spawn/nowaito spawn/detach
+ process? process-exit-status process-returned-normally? process-input-port
+ process-output-port process-error-port process-id)
(import scheme chicken.base chicken.fixnum chicken.platform)
@@ -251,6 +253,14 @@
(define process*)
(define process-sleep)
+(define process?)
+(define process-exit-status)
+(define process-returned-normally?)
+(define process-input-port)
+(define process-output-port)
+(define process-error-port)
+(define process-id)
+
(define pipe/buf)
(define spawn/overlay)
diff --git a/posixunix.scm b/posixunix.scm
index 9f6fdb28..a3fe86b9 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1092,24 +1092,39 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
;;; Process handling:
+(define c-string->allocated-pointer
+ (foreign-lambda* c-pointer ((scheme-object o))
+ "char *ptr = C_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);"))
+
(set! chicken.process#process-fork
(let ((fork (foreign-lambda int "C_fork")))
(lambda (#!optional thunk killothers)
;; flush all stdio streams before fork
((foreign-lambda int "C_fflush" c-pointer) #f)
- (let ((pid (fork)))
- (when (fx= -1 pid)
- (posix-error #:process-error 'process-fork "cannot create child process"))
- (if (and thunk (zero? pid))
- ((if killothers
- ##sys#kill-other-threads
- (lambda (thunk) (thunk)))
- (lambda ()
- (##sys#call-with-cthulhu
- (lambda ()
- (thunk)
- (exit 0)))))
- pid)))))
+ (let ((pid (fork))
+ (maybe-kill-others (lambda (thunk)
+ (if killothers
+ (##sys#kill-other-threads thunk)
+ (thunk)))))
+ (when (fx= -1 pid)
+ (posix-error #:process-error 'process-fork "cannot create child process"))
+ (cond ((zero? pid)
+ ;; child
+ (cond (thunk
+ (##sys#call-with-cthulhu
+ (maybe-kill-others (lambda ()
+ (set! children '())
+ (thunk)
+ (exit 0)))))
+ (else
+ (maybe-kill-others (lambda ()
+ (set! children '())
+ #f)))))
+ (else (register-pid pid)))))))
(set! chicken.process#process-execute
(lambda (filename #!optional (arglist '()) envlist _)
@@ -1143,11 +1158,14 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(set! chicken.process#process-signal
(lambda (id . sig)
- (let ((sig (if (pair? sig) (car sig) _sigterm)))
- (##sys#check-fixnum id 'process-signal)
+ (let ((sig (if (pair? sig) (car sig) _sigterm))
+ (pid (if (process? id) (process-id id) id)))
+ (##sys#check-fixnum pid 'process-signal)
(##sys#check-fixnum sig 'process-signal)
- (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) ) ) ) ) )
+ (let ((r (##core#inline "C_kill" pid sig)))
+ (when (fx= r -1)
+ (posix-error #:process-error 'process-signal
+ "could not send signal to process" id sig) ) ) ) ) )
(define (shell-command loc)
(or (get-environment-variable "SHELL") "/bin/sh") )
@@ -1158,13 +1176,13 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(set! chicken.process#process-run
(lambda (f . args)
(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)) ) ) ) ) )
+ (proc (chicken.process#process-fork)) )
+ (cond (proc)
+ (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:
@@ -1187,24 +1205,28 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(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) ) )) )
+ (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) (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))) ))
+ (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)
+ (and-let* ((a (assq pid children)))
+ (process-returned-normally?-set! (cdr a) flg)
+ (process-exit-status-set! (cdr a) flg)
+ (drop-child pid))
+ (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
@@ -1244,56 +1266,53 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(and-let* ([fd (connect-parent loc pipe stdf stdfd)])
(##sys#custom-output-port loc cmd fd #t DEFAULT-OUTPUT-BUFFER-SIZE on-close enc) ) )] )
(lambda (loc cmd args env stdoutf stdinf stderrf enc)
- (receive [inpipe outpipe errpipe pid]
+ (receive [inpipe outpipe errpipe proc]
(spawn loc cmd args env stdoutf stdinf stderrf)
;When shared assume already "closed", since only created ports
;should be explicitly closed, and when one is closed we want
;to wait.
- (let ((clsvec (vector (not stdinf) (not stdoutf) (not stderrf))))
- (values
- (input-port loc pid cmd inpipe stdinf
- chicken.file.posix#fileno/stdin
- (make-on-close loc pid clsvec 0 1 2)
- enc)
- (output-port loc pid cmd outpipe stdoutf
- chicken.file.posix#fileno/stdout
- (make-on-close loc pid clsvec 1 0 2)
- enc)
- pid
- (input-port loc pid cmd errpipe stderrf
- chicken.file.posix#fileno/stderr
- (make-on-close loc pid clsvec 2 0 1)
- enc) ) ) ) ) ) ) ) )
+ (let ((clsvec (vector (not stdinf) (not stdoutf) (not stderrf)))
+ (pid (process-id proc)))
+ (process-output-port-set! proc
+ (input-port loc pid cmd inpipe stdinf
+ chicken.file.posix#fileno/stdin
+ (make-on-close loc pid clsvec 0 1 2)
+ enc))
+ (process-input-port-set! proc
+ (output-port loc pid cmd outpipe stdoutf
+ chicken.file.posix#fileno/stdout
+ (make-on-close loc pid clsvec 1 0 2)
+ enc))
+ (process-error-port-set! proc
+ (input-port loc pid cmd errpipe stderrf
+ chicken.file.posix#fileno/stderr
+ (make-on-close loc pid clsvec 2 0 1)
+ enc) )
+ proc) ) ) ) ) ) )
;;; Run subprocess connected with pipes:
;; TODO: See if this can be moved to posix-common
(let ((%process
- (lambda (loc err? cmd args env enc k)
+ (lambda (loc err? cmd args env enc)
(let ((chkstrlst
- (lambda (lst)
- (##sys#check-list lst loc)
- (for-each (cut ##sys#check-string <> loc) lst) )))
+ (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 (shell-command-arguments cmd))
(set! cmd (shell-command loc)) ) )
- (when env (check-environment-list env loc))
- (##sys#call-with-values
- (lambda () (process-impl loc cmd args env #t #t err? enc))
- k)))))
+ (when env (check-environment-list env loc))
+ (process-impl loc cmd args env #t #t err? enc)))))
(set! chicken.process#process
(lambda (cmd #!optional args env (enc 'utf-8) exactf)
- (%process
- 'process #f cmd args env enc
- (lambda (i o p e) (values i o p)))))
+ (%process 'process #f cmd args env enc)))
(set! chicken.process#process*
(lambda (cmd #!optional args env (enc 'utf-8) exactf)
- (%process
- 'process* #t cmd args env enc
- values))))
+ (%process 'process* #t cmd args env enc))))
;;; chroot:
diff --git a/posixwin.scm b/posixwin.scm
index 41616c65..3d5e0f9d 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -107,30 +107,23 @@ static C_char C_username[255 + 1] = "";
#define open_text_input_pipe(a, n, name) open_binary_input_pipe(a, n, name)
#define open_binary_output_pipe(a, n, name) C_mpointer(a, _wpopen(C_OS_FILENAME(name, 0), L"w"))
#define open_text_output_pipe(a, n, name) open_binary_output_pipe(a, n, name)
-#define close_pipe(p) C_fix(_pclose(C_port_file(p)))
+#define close_pipe(p) C_fix(_pclose(C_port_file(p)))
-#define C_chmod(fn, m) C_fix(_wchmod(C_OS_FILENAME(fn, 0), C_unfix(m)))
-#define C_pipe(d, m) C_fix(_pipe(C_pipefds, PIPE_BUF, C_unfix(m)))
-#define C_close(fd) C_fix(close(C_unfix(fd)))
+#define C_chmod(fn, m) C_fix(_wchmod(C_OS_FILENAME(fn, 0), C_unfix(m)))
+#define C_pipe(d, m) C_fix(_pipe(C_pipefds, PIPE_BUF, C_unfix(m)))
+#define C_close(fd) C_fix(close(C_unfix(fd)))
#define C_u_i_lstat(fn) C_u_i_stat(fn)
-#define C_u_i_execvp(f, a) C_fix(execvp(C_c_string(f), (void *)C_c_pointer_vector_or_null(a)))
-#define C_u_i_execve(f,a,e) C_fix(execve(C_c_string(f), (void *)C_c_pointer_vector_or_null(a), (void *)C_c_pointer_vector_or_null(e)))
-
-/* MS replacement for the fork-exec pair */
-#define C_u_i_spawnvp(m,f,a) C_fix(spawnvp(C_unfix(m), C_c_string(f), (void *)C_c_pointer_vector_or_null(a)))
-#define C_u_i_spawnvpe(m,f,a,e) C_fix(spawnvpe(C_unfix(m), C_c_string(f), (void *)C_c_pointer_vector_or_null(a), (void *)C_c_pointer_vector_or_null(e)))
-
#define C_open(fn, fl, m) C_fix(_wopen(C_OS_FILENAME(fn, 0), C_unfix(fl), C_unfix(m)))
#define C_read(fd, b, n) C_fix(read(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
#define C_write(fd, b, n) C_fix(write(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
-#define C_flushall() C_fix(_flushall())
+#define C_flushall() C_fix(_flushall())
#define C_umask(m) C_fix(_umask(C_unfix(m)))
-#define C_ctime(n) (C_secs = (n), ctime(&C_secs))
+#define C_ctime(n) (C_secs = (n), ctime(&C_secs))
#define TIME_STRING_MAXLENGTH 255
static char C_time_string [TIME_STRING_MAXLENGTH + 1];
@@ -305,14 +298,14 @@ C_windows_nt()
static int
get_shlcmd()
{
- static wchar_t buf[ 255 ];
+ static wchar_t buf[ 255 ];
/* Do we need to build the shell command pathname? */
if (!strlen(C_shlcmd))
{
char *cmdnam = C_windows_nt() ? "\\cmd.exe" : "\\command.com";
- UINT len = GetSystemDirectoryW(buf, sizeof(buf) - strlen(cmdnam));
+ UINT len = GetSystemDirectoryW(buf, sizeof(buf));
if (len)
- C_strlcpy(C_shlcmd + len, cmdnam, sizeof(C_shlcmd));
+ C_strlcpy(C_shlcmd + len, C_utf8(buf), sizeof(C_shlcmd));
else
return set_last_errno();
}
@@ -328,7 +321,7 @@ get_shlcmd()
static int
get_user_name()
{
- static wchar_t buf[ 255 ];
+ static wchar_t buf[ 255 ];
if (!C_strlen(C_username))
{
DWORD bufCharCount = sizeof(buf) / sizeof(buf[0]);
@@ -344,36 +337,37 @@ get_user_name()
/*
Spawn a process directly.
Params:
- app Command to execute.
- cmdlin Command line (arguments).
- env Environment for the new process (may be NULL).
+ app Command to execute.
+ cmdlin Command line (arguments).
+ env Environment for the new process (may be NULL).
handle, stdin, stdout, stderr
- Spawned process info are returned in integers.
- When spawned process shares standard io stream with the parent
- process the respective value in handle, stdin, stdout, stderr
- is -1.
- params A bitmask controling operation.
- Bit 1: Child & parent share standard input if this bit is set.
- Bit 2: Share standard output if bit is set.
- Bit 3: Share standard error if bit is set.
-
- Returns: zero return value indicates failure.
+ Spawned process info are returned in integers.
+ When spawned process shares standard io stream with the parent
+ process the respective value in handle, stdin, stdout, stderr
+ is -1.
+ params A bitmask controling operation.
+ Bit 1: Child & parent share standard input if this bit is set.
+ Bit 2: Share standard output if bit is set.
+ Bit 3: Share standard error if bit is set.
+
+ Returns: pid, zero return value indicates failure.
*/
-static int
+static DWORD
C_process(const char *app, const char *cmdlin, const char **env,
- int *phandle, int *pstdin_fd, int *pstdout_fd, int *pstderr_fd,
- int params)
+ int *phandle, int *pstdin_fd, int *pstdout_fd, int *pstderr_fd,
+ int params)
{
int i;
int success = TRUE;
+ DWORD pid;
const int f_share_io[3] = { params & 1, params & 2, params & 4};
int io_fds[3] = { -1, -1, -1 };
HANDLE
- child_io_handles[3] = { NULL, NULL, NULL },
- standard_io_handles[3] = {
- GetStdHandle(STD_INPUT_HANDLE),
- GetStdHandle(STD_OUTPUT_HANDLE),
- GetStdHandle(STD_ERROR_HANDLE)};
+ child_io_handles[3] = { NULL, NULL, NULL },
+ standard_io_handles[3] = {
+ GetStdHandle(STD_INPUT_HANDLE),
+ GetStdHandle(STD_OUTPUT_HANDLE),
+ GetStdHandle(STD_ERROR_HANDLE)};
const char modes[3] = "rww";
HANDLE cur_process = GetCurrentProcess(), child_process = NULL;
void* envblk = NULL;
@@ -411,24 +405,26 @@ C_process(const char *app, const char *cmdlin, const char **env,
if (env && success)
{
- char** p;
- int len = 0;
-
- for (p = env; *p; ++p) len += strlen(*p) + 1;
-
- if (envblk = C_malloc(len + 1))
- {
- char* pb = (char*)envblk;
- for (p = env; *p; ++p)
- {
- C_strlcpy(pb, *p, len+1);
- pb += strlen(*p) + 1;
- }
- *pb = '\0';
+ char** p;
+ int len = 0;
+
+ for (p = env; *p; ++p) len += strlen(*p) + 1;
+
+ if (envblk = C_malloc((len + 1) * sizeof(wchar_t));
+ {
+ wchar_t* pb = (wchar_t*)envblk;
+ for (p = env; *p; ++p)
+ {
+ wchar_t *u = C_utf16(*p, 0);
+ int n = wcslen(*u);
+ C_memcpy(pb, *u, n + 1);
+ pb += n + 1;
+ }
+ *pb = '\0';
/* This _should_ already have been checked for embedded NUL bytes */
- }
- else
- success = FALSE;
+ }
+ else
+ success = FALSE;
}
#endif
@@ -436,31 +432,32 @@ C_process(const char *app, const char *cmdlin, const char **env,
if (success)
{
- PROCESS_INFORMATION pi;
- STARTUPINFO si;
-
- ZeroMemory(&pi,sizeof pi);
- ZeroMemory(&si,sizeof si);
- si.cb = sizeof si;
- si.dwFlags = STARTF_USESTDHANDLES;
- si.hStdInput = child_io_handles[0];
- si.hStdOutput = child_io_handles[1];
- si.hStdError = child_io_handles[2];
-
- /* FIXME passing 'app' param causes failure & possible stack corruption */
- success = CreateProcess(
- NULL, (char*)cmdlin, NULL, NULL, TRUE, 0, envblk, NULL, &si, &pi);
-
- if (success)
- {
- child_process=pi.hProcess;
- CloseHandle(pi.hThread);
- }
- else
- set_last_errno();
+ PROCESS_INFORMATION pi;
+ STARTUPINFO si;
+
+ ZeroMemory(&pi,sizeof pi);
+ ZeroMemory(&si,sizeof si);
+ si.cb = sizeof si;
+ si.dwFlags = STARTF_USESTDHANDLES;
+ si.hStdInput = child_io_handles[0];
+ si.hStdOutput = child_io_handles[1];
+ si.hStdError = child_io_handles[2];
+
+ /* FIXME passing 'app' param causes failure & possible stack corruption */
+ success = CreateProcessW(
+ NULL, C_utf16(cmdlin, 0), NULL, NULL, TRUE, 0, envblk, NULL, &si, &pi);
+
+ if (success)
+ {
+ child_process=pi.hProcess;
+ CloseHandle(pi.hThread);
+ pid = pi.dwProcessId;
+ }
+ else
+ set_last_errno();
}
else
- set_last_errno();
+ set_last_errno();
/****** cleanup & return *********/
@@ -513,6 +510,13 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
return _wutime(fn, &tb);
}
+#define C_u_i_execvp(f, a) C_fix(_wexecvp(C_c_string(f), (void *)C_c_pointer_vector_or_null(a)))
+#define C_u_i_execve(f,a,e) C_fix(_wexecve(C_c_string(f), (void *)C_c_pointer_vector_or_null(a), (void *)C_c_pointer_vector_or_null(e)))
+
+/* MS replacement for the fork-exec pair */
+#define C_u_i_spawnvp(m,f,a) C_fix(_wspawnvp(C_unfix(m), C_c_string(f), (void *)C_c_pointer_vector_or_null(a)))
+#define C_u_i_spawnvpe(m,f,a,e) C_fix(_wspawnvpe(C_unfix(m), C_c_string(f), (void *)C_c_pointer_vector_or_null(a), (void *)C_c_pointer_vector_or_null(e)))
+
<#
(import (only chicken.string string-intersperse))
@@ -717,18 +721,27 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
; string-quote such arguments.
(define quote-arg-string
(let ((needs-quoting?
- ;; This is essentially (string-any char-whitespace? s) but we
- ;; don't want a SRFI-13 dependency. (Do we?)
- (lambda (s)
- (let ((len (string-length s)))
- (let loop ((i 0))
- (cond
- ((fx= i len) #f)
- ((char-whitespace? (string-ref s i)) #t)
- (else (loop (fx+ i 1)))))))))
+ ;; This is essentially (string-any char-whitespace? s) but we
+ ;; don't want a SRFI-13 dependency. (Do we?)
+ (lambda (s)
+ (let ((len (string-length s)))
+ (let loop ((i 0))
+ (cond
+ ((fx= i len) #f)
+ ((char-whitespace? (string-ref s i)) #t)
+ (else (loop (fx+ i 1)))))))))
(lambda (str)
(if (needs-quoting? str) (string-append "\"" str "\"") str))))
+(define c-string->allocated-pointer
+ (foreign-lambda* c-pointer ((scheme-object o))
+ "char *ptr = C_malloc(C_header_size(o) * sizeof(wchar_t)); \n"
+ "if (ptr != NULL) {\n"
+ " wchar_t *u = C_utf16(C_data_pointer(o), 0); \n"
+ " C_memcpy(ptr, u, wcslen(u) + 1); \n"
+ "}\n"
+ "C_return(ptr);"))
+
(set! chicken.process#process-execute
(lambda (filename #!optional (arglist '()) envlist exactf)
(let ((argconv (if exactf (lambda (x) x) quote-arg-string)))
@@ -749,13 +762,14 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(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))))))
+ (##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))))
+ (if (fx= r -1)
+ (posix-error #:process-error 'process-spawn
+ "cannot spawn process" filename)
+ (register-pid r))))))))
(define-foreign-variable _shlcmd c-string "C_shlcmd")
@@ -808,62 +822,60 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
; For now any environment is ignored.
(lambda (loc cmd args env stdoutf stdinf stderrf exactf enc)
(let* ((arglist (cons cmd args))
- (cmdlin (string-intersperse
- (if exactf
- arglist
- (map quote-arg-string arglist)))))
- (let-location ([handle int -1]
- [stdin_fd int -1] [stdout_fd int -1] [stderr_fd int -1])
- (let ([res
- (c-process cmd cmdlin #f
- (location handle)
- (location stdin_fd) (location stdout_fd) (location stderr_fd)
- (+ (if stdinf 0 1) (if stdoutf 0 2) (if stderrf 0 4)))])
- (if res
- (values
- (and stdoutf (chicken.file.posix#open-input-file*
- stdout_fd)) ;Parent stdin
- (and stdinf (chicken.file.posix#open-output-file*
- stdin_fd)) ;Parent stdout
- handle
- (and stderrf (chicken.file.posix#open-input-file*
- stderr_fd)))
+ (cmdlin (string-intersperse
+ (if exactf
+ arglist
+ (map quote-arg-string arglist)))))
+ (let-location ([handle int -1]
+ [stdin_fd int -1] [stdout_fd int -1] [stderr_fd int -1])
+ (let ([res
+ (c-process cmd cmdlin #f
+ (location handle)
+ (location stdin_fd) (location stdout_fd) (location stderr_fd)
+ (+ (if stdinf 0 1) (if stdoutf 0 2) (if stderrf 0 4)))])
+ (if (integer? res)
+ (make-process
+ res #f
+ (and stdoutf (chicken.file.posix#open-input-file*
+ stdout_fd)) ;Parent stdin
+ (and stdinf (chicken.file.posix#open-output-file*
+ stdin_fd)) ;Parent stdout
+ handle
+ (and stderrf (chicken.file.posix#open-input-file*
+ stderr_fd)
+ #f))
(##sys#signal-hook/errno
#:process-error (##sys#update-errno) loc "cannot execute process" cmdlin))))))))
;; TODO: See if this can be moved to posix-common
(let ((%process
- (lambda (loc err? cmd args env exactf enc)
- (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! exactf #t)
- (set! args (shell-command-arguments cmd))
- (set! cmd (shell-command loc)) ) )
- (when env (check-environment-list env loc))
- (receive (in out pid err)
- (process-impl loc cmd args env #t #t err? exactf enc)
- (if err?
- (values in out pid err)
- (values in out pid) ) ) ) )) )
+ (lambda (loc cmd args env exactf enc)
+ (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! exactf #t)
+ (set! args (shell-command-arguments cmd))
+ (set! cmd (shell-command loc)) ) )
+ (when env (check-environment-list env loc))
+ (process-impl loc cmd args env #t #t err? exactf enc)))))
(set! chicken.process#process
(lambda (cmd #!optional args env (enc 'utf-8) exactf)
- (%process 'process #f cmd args env exactf enc) ))
+ (%process 'process cmd args env exactf enc) ))
(set! chicken.process#process*
(lambda (cmd #!optional args env (enc 'utf-8) exactf)
- (%process 'process* #t cmd args env exactf enc) )) )
+ (%process 'process* cmd args env exactf enc) )) )
(define-foreign-variable _exstatus int "C_exstatus")
(define (process-wait-impl pid nohang)
- (if (##core#inline "C_process_wait" pid nohang)
- (values pid #t _exstatus)
- (values -1 #f #f) ) )
+ (cond ((##core#inline "C_process_wait" pid nohang)
+ (values pid #t _exstatus))
+ (else (values -1 #f #f) ) ))
;;; Getting group- and user-information:
diff --git a/tests/posix-tests.scm b/tests/posix-tests.scm
index dccd483f..0aa3c7a3 100644
--- a/tests/posix-tests.scm
+++ b/tests/posix-tests.scm
@@ -41,17 +41,15 @@
(assert-error (process-execute "false" '("1" "123\x00;456")))
(assert-error (process-execute "false" '("123\x00;456") '(("foo\x00;bar" . "blabla") '("lalala" . "qux\x00;mooh"))))
-(receive (in out pid)
- (process csi-path '("-n" "-I" ".." "-e"
- "(write 'err (current-error-port)) (write 'ok)"))
- (assert (equal? 'ok (read in)))
+(let ((p (process csi-path '("-n" "-I" ".." "-e"
+ "(write 'err (current-error-port)) (write 'ok)"))))
+ (assert (equal? 'ok (read (process-output-port p))))
(newline (current-error-port)))
-(receive (in out pid err)
- (process* csi-path '("-n" "-I" ".." "-e"
- "(write 'err (current-error-port)) (write 'ok)"))
- (assert (equal? 'ok (read in)))
- (assert (equal? 'err (read err))))
+(let ((p (process* csi-path '("-n" "-I" ".." "-e"
+ "(write 'err (current-error-port)) (write 'ok)"))))
+ (assert (equal? 'ok (read (process-output-port p))))
+ (assert (equal? 'err (read (process-error-port p)))))
;; delete-directory
(let* ((t (create-temporary-directory))
diff --git a/types.db b/types.db
index 3d10f564..79e5071f 100644
--- a/types.db
+++ b/types.db
@@ -2168,18 +2168,25 @@
(chicken.process#process-execute
(#(procedure #:clean #:enforce) chicken.process#process-execute (string #!optional (list-of string) (list-of (pair string string)) boolean) noreturn))
-(chicken.process#process-fork (#(procedure #:enforce) chicken.process#process-fork (#!optional (or (procedure () . *) false) *) fixnum))
+(chicken.process#process-fork (#(procedure #:enforce) chicken.process#process-fork (#!optional (or (procedure () . *) false) *) (or (struct process) boolean)))
(chicken.process#qs (#(procedure #:clean #:enforce) chicken.process#qs (string #!optional symbol) 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-run (#(procedure #:clean #:enforce) chicken.process#process-run (string #!optional (list-of string)) (struct process)))
+(chicken.process#process-signal (#(procedure #:clean #:enforce) chicken.process#process-signal ((or (struct process) 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))
+ (#(procedure #:clean #:enforce) chicken.process#process-spawn (fixnum string #!optional (list-of string) (list-of (pair string string)) boolean) (struct process)))
(chicken.process#system (#(procedure #:clean #:enforce) chicken.process#system (string) fixnum))
(chicken.process#system* (#(procedure #:clean #:enforce) chicken.process#system* (string) undefined))
-(chicken.process#process (#(procedure #:clean #:enforce) chicken.process#process (string #!optional (list-of string) (list-of (pair string string)) symbol 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)) symbol 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 (#(procedure #:clean #:enforce) chicken.process#process (string #!optional (list-of string) (list-of (pair string string)) symbol boolean) (struct process)))
+(chicken.process#process* (#(procedure #:clean #:enforce) chicken.process#process* (string #!optional (list-of string) (list-of (pair string string)) symbol boolean) (struct process)))
+(chicken.process#process-wait (#(procedure #:clean #:enforce) chicken.process#process-wait (#!optional (or (struct process) fixnum) *) fixnum fixnum fixnum))
(chicken.process#process-sleep (#(procedure #:clean #:enforce) chicken.process#process-sleep (fixnum) fixnum))
+(chicken.process#process-exit-status (#(procedure #:clean #:enforce) chicken.process#process-exit-status ((struct process)) *))
+(chicken.process#process-input-port (#(procedure #:clean #:enforce) chicken.process#process-input-port ((struct process)) output-port))
+(chicken.process#process-output-port (#(procedure #:clean #:enforce) chicken.process#process-output-port ((struct process)) input-port))
+(chicken.process#process-error-port (#(procedure #:clean #:enforce) chicken.process#process-error-port ((struct process)) input-port))
+(chicken.process#process-id (#(procedure #:clean #:enforce) chicken.process#process-id ((struct process)) fixnum))
+(chicken.process#process-returned-normally? (#(procedure #:clean #:enforce) chicken.process#process-returned-normally? ((struct process)) boolean))
+(chicken.process#process? (#(procedure #:clean #:enforce) chicken.process#process? (*) boolean))
(chicken.process#call-with-input-pipe (#(procedure #:enforce) chicken.process#call-with-input-pipe (string (procedure (input-port) . *) #!optional keyword) . *))
(chicken.process#call-with-output-pipe (#(procedure #:enforce) chicken.process#call-with-output-pipe (string (procedure (input-port) . *) #!optional keyword) . *))
(chicken.process#close-input-pipe (#(procedure #:clean #:enforce) chicken.process#close-input-pipe (input-port) fixnum))
Trap