ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

guix: inferior: Fix the behaviour of open-inferior #:error-port.

Browse source 
I'm looking at this as the Guix Data Service uses this behaviour to record and
display logs from inferior processes.

* guix/inferior.scm (open-bidirectional-pipe): Call dup2 for file descriptor
2, passing either the file number for the current error port, or a file
descriptor for /dev/null.
* tests/inferior.scm ("#:error-port stderr", "#:error-port pipe"): Add two new
tests that cover some of the #:error-port behaviour.
This commit is contained in:
Christopher Baines 2022-06-25 18:14:07 +01:00
parent 37dd7e53b9
commit b4c4a6acb1
No known key found for this signature in database
GPG key ID: 5E28A33B0B84F577
2 changed files with 47 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
guix/inferior.scm
View file

@ -156,12 +156,18 @@ (define (open-bidirectional-pipe command . args)
(close-port parent)
(close-fdes 0)
(close-fdes 1)
(close-fdes 2)
(dup2 (fileno child) 0)
(dup2 (fileno child) 1)
;; Mimic 'open-pipe*'.
(unless (file-port? (current-error-port))
(close-fdes 2)
(dup2 (open-fdes "/dev/null" O_WRONLY) 2))
(if (file-port? (current-error-port))
(let ((error-port-fileno
(fileno (current-error-port))))
(unless (eq? error-port-fileno 2)
(dup2 error-port-fileno
2)))
(dup2 (open-fdes "/dev/null" O_WRONLY)
2))
(apply execlp command command args))
(lambda ()
(primitive-_exit 127))))

39
tests/inferior.scm
View file

@ -30,7 +30,8 @@ (define-module (test-inferior)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-64)
#:use-module (ice-9 match))
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim))
(define %top-srcdir
(dirname (search-path %load-path "guix.scm")))
@ -315,4 +316,40 @@ (define result
(close-inferior inferior)
(map manifest-entry->list (manifest-entries manifest))))
(test-equal "#:error-port stderr"
42
;; There's a special case in open-bidirectional-pipe for
;; (current-error-port) being stderr, so this test just checks that
;; open-inferior doesn't raise an exception
(let ((inferior (open-inferior %top-builddir
#:command "scripts/guix"
#:error-port (current-error-port))))
(and (inferior? inferior)
(inferior-eval '(display "test" (current-error-port)) inferior)
(let ((result (inferior-eval '(apply * '(6 7)) inferior)))
(close-inferior inferior)
result))))
(test-equal "#:error-port pipe"
"42"
(match (pipe)
((port-to-read-from . port-to-write-to)
(setvbuf port-to-read-from 'line)
(setvbuf port-to-write-to 'line)
(let ((inferior (open-inferior %top-builddir
#:command "scripts/guix"
#:error-port port-to-write-to)))
(and (inferior? inferior)
(begin
(inferior-eval '(display "42\n" (current-error-port)) inferior)
(let loop ((line (read-line port-to-read-from)))
(if (string=? line "42")
(begin
(close-inferior inferior)
line)
(loop (read-line port-to-read-from))))))))))
(test-end "inferior")