summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2021-10-19 10:56:38 +0200
committerLudovic Courtès <ludo@gnu.org>2021-10-26 12:46:27 +0200
commitf87371bf3e952a211782311dad2971c8820a5150 (patch)
tree61f021da081f0e638d64f3080cff3d6855c1078b
parentb7b0ac85443c719a616edee6963578e58396f339 (diff)
syscalls: Add 'openpty' and 'login-tty'.
* guix/build/syscalls.scm (openpty, login-pty): New procedures. * tests/syscalls.scm ("openpty", "openpty + login-tty"): New tests.
-rw-r--r--guix/build/syscalls.scm39
-rw-r--r--tests/syscalls.scm35
2 files changed, 74 insertions, 0 deletions
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 @@
terminal-window-size
terminal-columns
terminal-rows
+ openpty
+ login-tty
utmpx?
utmpx-login-type
@@ -2286,6 +2288,43 @@ PORT, trying to guess a reasonable value if all else fails. The result is
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 @@
#: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 @@
(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) ...)