diff options
| -rw-r--r-- | guix/build/syscalls.scm | 131 | ||||
| -rw-r--r-- | tests/syscalls.scm | 25 |
2 files changed, 156 insertions, 0 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 721c590f69..4e543d70d8 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -100,6 +100,22 @@ interface-broadcast-address network-interfaces + termios? + termios-input-flags + termios-output-flags + termios-control-flags + termios-local-flags + termios-line-discipline + termios-control-chars + termios-input-speed + termios-output-speed + local-flags + TCSANOW + TCSADRAIN + TCSAFLUSH + tcgetattr + tcsetattr + window-size? window-size-rows window-size-columns @@ -996,6 +1012,121 @@ network interface. This is implemented using the 'getifaddrs' libc function." ;;; Terminals. ;;; +(define-syntax bits->symbols-body + (syntax-rules () + ((_ bits () ()) + '()) + ((_ bits (name names ...) (value values ...)) + (let ((result (bits->symbols-body bits (names ...) (values ...)))) + (if (zero? (logand bits value)) + result + (cons 'name result)))))) + +(define-syntax define-bits + (syntax-rules (define) + "Define the given numerical constants under CONSTRUCTOR, such that + (CONSTRUCTOR NAME) returns VALUE. Define BITS->SYMBOLS as a procedure that, +given an integer, returns the list of names of the constants that are or'd." + ((_ constructor bits->symbols (define names values) ...) + (begin + (define-syntax constructor + (syntax-rules (names ...) + ((_ names) values) ... + ((_ several (... ...)) + (logior (constructor several) (... ...))))) + (define (bits->symbols bits) + (bits->symbols-body bits (names ...) (values ...))) + (define names values) ...)))) + +;; 'local-flags' bits from <bits/termios.h> +(define-bits local-flags + local-flags->symbols + (define ISIG #o0000001) + (define ICANON #o0000002) + (define XCASE #o0000004) + (define ECHO #o0000010) + (define ECHOE #o0000020) + (define ECHOK #o0000040) + (define ECHONL #o0000100) + (define NOFLSH #o0000200) + (define TOSTOP #o0000400) + (define ECHOCTL #o0001000) + (define ECHOPRT #o0002000) + (define ECHOKE #o0004000) + (define FLUSHO #o0010000) + (define PENDIN #o0040000) + (define IEXTEN #o0100000) + (define EXTPROC #o0200000)) + +;; "Actions" values for 'tcsetattr'. +(define TCSANOW 0) +(define TCSADRAIN 1) +(define TCSAFLUSH 2) + +(define-record-type <termios> + (termios input-flags output-flags control-flags local-flags + line-discipline control-chars + input-speed output-speed) + termios? + (input-flags termios-input-flags) + (output-flags termios-output-flags) + (control-flags termios-control-flags) + (local-flags termios-local-flags) + (line-discipline termios-line-discipline) + (control-chars termios-control-chars) + (input-speed termios-input-speed) + (output-speed termios-output-speed)) + +(define-c-struct %termios ;<bits/termios.h> + sizeof-termios + termios + read-termios + write-termios! + (input-flags unsigned-int) + (output-flags unsigned-int) + (control-flags unsigned-int) + (local-flags unsigned-int) + (line-discipline uint8) + (control-chars (array uint8 32)) + (input-speed unsigned-int) + (output-speed unsigned-int)) + +(define tcgetattr + (let ((proc (syscall->procedure int "tcgetattr" (list int '*)))) + (lambda (fd) + "Return the <termios> structure for the tty at FD." + (let* ((bv (make-bytevector sizeof-termios)) + (ret (proc fd (bytevector->pointer bv))) + (err (errno))) + (if (zero? ret) + (read-termios bv) + (throw 'system-error "tcgetattr" "~A" + (list (strerror err)) + (list err))))))) + +(define tcsetattr + (let ((proc (syscall->procedure int "tcsetattr" (list int int '*)))) + (lambda (fd actions termios) + "Use TERMIOS for the tty at FD. ACTIONS is one of 'TCSANOW', +'TCSADRAIN', or 'TCSAFLUSH'; see tcsetattr(3) for details." + (define bv + (make-bytevector sizeof-termios)) + + (let-syntax ((match/write (syntax-rules () + ((_ fields ...) + (match termios + (($ <termios> fields ...) + (write-termios! bv 0 fields ...))))))) + (match/write input-flags output-flags control-flags local-flags + line-discipline control-chars input-speed output-speed)) + + (let ((ret (proc fd actions (bytevector->pointer bv))) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "tcgetattr" "~A" + (list (strerror err)) + (list err))))))) + (define-syntax TIOCGWINSZ ;<asm-generic/ioctls.h> (identifier-syntax #x5413)) diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 71bcbc4d32..ab1e13984d 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -259,6 +259,31 @@ (#f #f) (lo (interface-address lo))))))) +(test-equal "tcgetattr ENOTTY" + ENOTTY + (catch 'system-error + (lambda () + (call-with-input-file "/dev/null" + (lambda (port) + (tcgetattr (fileno port))))) + (compose system-error-errno list))) + +(test-skip (if (and (file-exists? "/proc/self/fd/0") + (string-prefix? "/dev/pts/" (readlink "/proc/self/fd/0"))) + 0 + 2)) + +(test-assert "tcgetattr" + (let ((termios (tcgetattr 0))) + (and (termios? termios) + (> (termios-input-speed termios) 0) + (> (termios-output-speed termios) 0)))) + +(test-assert "tcsetattr" + (let ((first (tcgetattr 0))) + (tcsetattr 0 TCSANOW first) + (equal? first (tcgetattr 0)))) + (test-assert "terminal-window-size ENOTTY" (call-with-input-file "/dev/null" (lambda (port) |