From f87371bf3e952a211782311dad2971c8820a5150 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 19 Oct 2021 10:56:38 +0200
Subject: syscalls: Add 'openpty' and 'login-tty'.

* guix/build/syscalls.scm (openpty, login-pty): New procedures.
* tests/syscalls.scm ("openpty", "openpty + login-tty"): New tests.
---
 guix/build/syscalls.scm | 39 +++++++++++++++++++++++++++++++++++++++
 tests/syscalls.scm      | 35 +++++++++++++++++++++++++++++++++++
 2 files changed, 74 insertions(+)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 99a3b45004..7ea6b56e54 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -180,6 +180,8 @@ (define-module (guix build syscalls)
             terminal-window-size
             terminal-columns
             terminal-rows
+            openpty
+            login-tty
 
             utmpx?
             utmpx-login-type
@@ -2286,6 +2288,43 @@ (define* (terminal-rows #:optional (port (current-output-port)))
 always a positive integer."
   (terminal-dimension window-size-rows port (const 25)))
 
+(define openpty
+  (let* ((ptr  (dynamic-func "openpty" (dynamic-link "libutil")))
+         (proc (pointer->procedure int ptr '(* * * * *)
+                                   #:return-errno? #t)))
+    (lambda ()
+      "Return two file descriptors: one for the pseudo-terminal control side,
+and one for the controlled side."
+      (let ((head     (make-bytevector (sizeof int)))
+            (inferior (make-bytevector (sizeof int))))
+        (let-values (((ret err)
+                      (proc (bytevector->pointer head)
+                            (bytevector->pointer inferior)
+                            %null-pointer %null-pointer %null-pointer)))
+          (unless (zero? ret)
+            (throw 'system-error "openpty" "~A"
+                   (list (strerror err))
+                   (list err))))
+
+        (let ((* (lambda (bv)
+                   (bytevector-sint-ref bv 0 (native-endianness)
+                                        (sizeof int)))))
+          (values (* head) (* inferior)))))))
+
+(define login-tty
+  (let* ((ptr  (dynamic-func "login_tty" (dynamic-link "libutil")))
+         (proc (pointer->procedure int ptr (list int)
+                                   #:return-errno? #t)))
+    (lambda (fd)
+      "Make FD the controlling terminal of the current process (with the
+TIOCSCTTY ioctl), redirect standard input, standard output and standard error
+output to this terminal, and close FD."
+      (let-values (((ret err) (proc fd)))
+        (unless (zero? ret)
+          (throw 'system-error "login-pty" "~A"
+                 (list (strerror err))
+                 (list err)))))))
+
 
 ;;;
 ;;; utmpx.
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 706dd4177f..c9e011f453 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -26,6 +26,7 @@ (define-module (test-syscalls)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
+  #:use-module (srfi srfi-71)
   #:use-module (system foreign)
   #:use-module ((ice-9 ftw) #:select (scandir))
   #:use-module (ice-9 match))
@@ -582,6 +583,40 @@ (define perform-container-tests?
 (test-assert "terminal-rows"
   (> (terminal-rows) 0))
 
+(test-assert "openpty"
+  (let ((head inferior (openpty)))
+    (and (integer? head) (integer? inferior)
+         (let ((port (fdopen inferior "r+0")))
+           (and (isatty? port)
+                (begin
+                  (close-port port)
+                  (close-fdes head)
+                  #t))))))
+
+(test-equal "openpty + login-tty"
+  '(hello world)
+  (let ((head inferior (openpty)))
+    (match (primitive-fork)
+      (0
+       (dynamic-wind
+         (const #t)
+         (lambda ()
+           (setvbuf (current-input-port) 'none)
+           (close-fdes head)
+           (login-tty inferior)
+           (write (read))
+           (read))                          ;this gets EIO when HEAD is closed
+         (lambda ()
+           (primitive-_exit 42))))
+      (pid
+       (close-fdes inferior)
+       (let ((head (fdopen head "r+0")))
+         (write '(hello world) head)
+         (let ((result (read head)))
+           (close-port head)
+           (waitpid pid)
+           result))))))
+
 (test-assert "utmpx-entries"
   (match (utmpx-entries)
     (((? utmpx? entries) ...)
-- 
cgit v1.2.3