Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 13:49:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding optional child-prod arg to call-with-process-io

Browse source
This commit is contained in:
Alex Shinn 2022-06-19 08:30:45 +09:00
parent 54d3aafc7b
commit f5d96939b6
1 changed files with 8 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
lib/chibi/process.scm
View file

@ -123,8 +123,11 @@
;;> \var{stdout} and \var{stderr} of the subprocess. \var{command} ;;> \var{stdout} and \var{stderr} of the subprocess. \var{command}
;;> should be a list beginning with the program name followed by any ;;> should be a list beginning with the program name followed by any
;;> args, which may be symbols or numbers for convenience as with ;;> args, which may be symbols or numbers for convenience as with
;;> \scheme{system}, or a string which is split on white-space. ;;> \scheme{system}, or a string which is split on white-space. If
(define (call-with-process-io command proc) ;;> provided, the optional \var{child-proc} is called in the child
;;> process, after ports have been duplicated but before the command
;;> is executed, to allow for actions such as port remapping.
(define (call-with-process-io command proc . o)
(define (set-non-blocking! fd) (define (set-non-blocking! fd)
(cond-expand (cond-expand
(threads (threads
@ -133,7 +136,8 @@
(bitwise-ior open/non-block (get-file-descriptor-status fd)))) (bitwise-ior open/non-block (get-file-descriptor-status fd))))
(else (else
#f))) #f)))
(let ((command-ls (if (string? command) (string-split command) command)) (let ((child-proc (and (pair? o) (car o)))
(command-ls (if (string? command) (string-split command) command))
(in-pipe (open-pipe)) (in-pipe (open-pipe))
(out-pipe (open-pipe)) (out-pipe (open-pipe))
(err-pipe (open-pipe))) (err-pipe (open-pipe)))
@ -152,6 +156,7 @@
(close-file-descriptor (car in-pipe)) (close-file-descriptor (car in-pipe))
(close-file-descriptor (cadr out-pipe)) (close-file-descriptor (cadr out-pipe))
(close-file-descriptor (cadr err-pipe)) (close-file-descriptor (cadr err-pipe))
(if child-proc (child-proc))
(execute (car command-ls) command-ls) (execute (car command-ls) command-ls)
(execute-returned command-ls)) (execute-returned command-ls))
(else ;; parent (else ;; parent