aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/utils.scm27
-rw-r--r--tests/utils.scm8
2 files changed, 27 insertions, 8 deletions
diff --git a/guix/utils.scm b/guix/utils.scm
index 68329ec915..15a4390074 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -155,18 +155,29 @@ COMMAND (a list). In addition, return a list of PIDs that the caller must
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 @@ buffered data is lost."
(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)))))))))
diff --git a/tests/utils.scm b/tests/utils.scm
index adac5d4381..85daa3db91 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -142,6 +142,14 @@
(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