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

[guix-commits]

cbaines pushed a commit to branch master
in repository guix.

commit b4c4a6acb1204ee53e95744236ee89985db32f91
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Sat Jun 25 18:14:07 2022 +0100

    guix: inferior: Fix the behaviour of open-inferior #:error-port.
    
    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.
---
 guix/inferior.scm  | 12 +++++++++---
 tests/inferior.scm | 39 ++++++++++++++++++++++++++++++++++++++-
 2 files changed, 47 insertions(+), 4 deletions(-)

diff --git a/guix/inferior.scm b/guix/inferior.scm
index 54200b75e4..20a86bbfda 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -156,12 +156,18 @@ custom binary port)."
             (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))))
diff --git a/tests/inferior.scm b/tests/inferior.scm
index 56b2fcb7bc..963d405e33 100644
--- a/tests/inferior.scm
+++ b/tests/inferior.scm
@@ -30,7 +30,8 @@
   #: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 @@
     (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")