~ruther/guix-local

443eb4e9506026094f5e0dadc3e11d3cf7a86a24 — Ludovic Courtès 12 years ago ca53466
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.
2 files changed, 27 insertions(+), 8 deletions(-)

M guix/utils.scm
M tests/utils.scm
M guix/utils.scm => guix/utils.scm +19 -8
@@ 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)))))))))

M tests/utils.scm => tests/utils.scm +8 -0
@@ 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