mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-25 05:48:07 -05:00
utils: 'filtered-port' doesn't leave dangling processes behind.
* guix/utils.scm (filtered-port): Make sure the 'execl' child process always exits, and does (primitive-_exit 1) upon execution failure. Use 'primitive-_exit' in the 'dump-port' child process. * tests/utils.scm ("filtered-port, does not exist"): New test.
This commit is contained in:
parent
ca534666aa
commit
443eb4e950
2 changed files with 27 additions and 8 deletions
|
@ -155,18 +155,29 @@ (define (filtered-port command input)
|
|||
wait. When INPUT is a file port, it must be unbuffered; otherwise, any
|
||||
buffered data is lost."
|
||||
(let loop ((input input)
|
||||
(pids '()))
|
||||
(pids '()))
|
||||
(if (file-port? input)
|
||||
(match (pipe)
|
||||
((in . out)
|
||||
(match (primitive-fork)
|
||||
(0
|
||||
(close-port in)
|
||||
(close-port (current-input-port))
|
||||
(dup2 (fileno input) 0)
|
||||
(close-port (current-output-port))
|
||||
(dup2 (fileno out) 1)
|
||||
(apply execl (car command) command))
|
||||
(dynamic-wind
|
||||
(const #f)
|
||||
(lambda ()
|
||||
(close-port in)
|
||||
(close-port (current-input-port))
|
||||
(dup2 (fileno input) 0)
|
||||
(close-port (current-output-port))
|
||||
(dup2 (fileno out) 1)
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(apply execl (car command) command))
|
||||
(lambda args
|
||||
(format (current-error-port)
|
||||
"filtered-port: failed to execute '~{~a ~}': ~a~%"
|
||||
command (strerror (system-error-errno args))))))
|
||||
(lambda ()
|
||||
(primitive-_exit 1))))
|
||||
(child
|
||||
(close-port out)
|
||||
(values in (cons child pids))))))
|
||||
|
@ -184,7 +195,7 @@ (define (filtered-port command input)
|
|||
(dump-port input out))
|
||||
(lambda ()
|
||||
(false-if-exception (close out))
|
||||
(primitive-exit 0))))
|
||||
(primitive-_exit 0))))
|
||||
(child
|
||||
(close-port out)
|
||||
(loop in (cons child pids)))))))))
|
||||
|
|
|
@ -142,6 +142,14 @@ (define temp-file
|
|||
(append pids1 pids2)))
|
||||
(equal? (get-bytevector-all decompressed) data)))))
|
||||
|
||||
(test-assert "filtered-port, does not exist"
|
||||
(let* ((file (search-path %load-path "guix.scm"))
|
||||
(input (open-file file "r0b")))
|
||||
(let-values (((port pids)
|
||||
(filtered-port '("/does/not/exist") input)))
|
||||
(any (compose (negate zero?) cdr waitpid)
|
||||
pids))))
|
||||
|
||||
(false-if-exception (delete-file temp-file))
|
||||
(test-equal "fcntl-flock wait"
|
||||
42 ; the child's exit status
|
||||
|
|
Loading…
Reference in a new issue