This is an attempt to fix #766. "process" and "process*" return a structure holding the process ports, exit status, pid, etc. Accessors for these slots are provided. "process-wait" accepts either a pid or a process object. This is somewhat nicer than returning a bunch of values and also allows retrieving the exit status even if the child was already waited upon as ports were closed.
felix
From f0309f5c6da0fc5abd1376065cb1f968e785c1c9 Mon Sep 17 00:00:00 2001 From: felix <[email protected]> Date: Tue, 31 Dec 2024 11:32:05 +0100 Subject: [PATCH] make process[*] return a process-object, add accessors, process-wait accepts pid or process-object --- NEWS | 4 + manual/Module (chicken process) | 73 +++++++++---- posix-common.scm | 20 +++- posix.scm | 12 ++- posixunix.scm | 47 ++++----- posixwin.scm | 177 ++++++++++++++++---------------- tests/posix-tests.scm | 16 ++- types.db | 11 +- 8 files changed, 215 insertions(+), 145 deletions(-) diff --git a/NEWS b/NEWS index 61df9e40..3b73aac0 100644 --- a/NEWS +++ b/NEWS @@ -14,6 +14,10 @@ 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' 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' accepts 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..bd622cc4 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 @@ -114,11 +115,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 +132,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 +154,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 +173,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 +189,38 @@ 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 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 +254,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..a1808386 100644 --- a/posix-common.scm +++ b/posix-common.scm @@ -677,6 +677,21 @@ EOF ;;; Processes +(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))) + +(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) @@ -685,9 +700,12 @@ EOF (set! chicken.process#process-wait (lambda args (let-optionals* args ((pid #f) (nohang #f)) - (let ((pid (or pid -1))) + (let ((pid (get-pid pid -1))) (##sys#check-fixnum pid 'process-wait) (receive (epid enorm ecode) (process-wait-impl pid nohang) + (when (process? pid) + (process-returned-normally?-set! pid enorm) + (process-exit-status-set! pid ecode)) (if (fx= epid -1) (posix-error #:process-error 'process-wait "waiting for child process failed" pid) (values epid enorm ecode) ) ) ) ) ) ) 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..9cd3b801 100644 --- a/posixunix.scm +++ b/posixunix.scm @@ -1249,21 +1249,24 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime) ;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))) + (proc (make-process pid #f #f #f #f #f))) + (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: @@ -1280,20 +1283,14 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime) (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 13c9a987..e960a86b 100644 --- a/posixwin.scm +++ b/posixwin.scm @@ -341,36 +341,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; @@ -433,31 +434,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 = CreateProcess( + NULL, (char*)cmdlin, 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 *********/ @@ -805,62 +807,63 @@ 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" (get-pid pid 0) nohang) + (when (process? pid) + (process-exit-status-set! pid _exstatus) + (process-returned-normally?-set! pid #t)) + (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 5ee90b8f..b9c08704 100644 --- a/types.db +++ b/types.db @@ -2176,10 +2176,17 @@ (#(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) 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 (#(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 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)) -- 2.42.0
