From 29ff6d9fcc05b283b6d797146330e950286028ed Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 14 Apr 2016 23:35:03 +0200 Subject: syscalls: Add TIOCGWINSZ bindings. * guix/build/syscalls.scm (TIOCGWINSZ): New macro. (): New record type. (winsize): New C struct. (winsize-struct): New variable. (terminal-window-size, terminal-columns): New procedures. --- tests/syscalls.scm | 13 +++++++++++++ 1 file changed, 13 insertions(+) (limited to 'tests/syscalls.scm') diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 8e24184fe2..1b443be0c8 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -244,4 +244,17 @@ (define perform-container-tests? (#f #f) (lo (interface-address lo))))))) +(test-equal "terminal-window-size ENOTTY" + ENOTTY + (call-with-input-file "/dev/null" + (lambda (port) + (catch 'system-error + (lambda () + (terminal-window-size port)) + (lambda args + (system-error-errno args)))))) + +(test-assert "terminal-columns" + (> (terminal-columns) 0)) + (test-end) -- cgit v1.2.3 From 6d2b43915f8a628588f03136b3008902f7643e06 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 15 Apr 2016 19:47:35 +0200 Subject: syscalls: 'terminal-columns' ignores non-file ports. * guix/build/syscalls.scm (terminal-columns): Call 'terminal-window-size' only when PORT is a file port. * tests/syscalls.scm ("terminal-columns non-file port"): New test. --- guix/build/syscalls.scm | 10 ++++++---- tests/syscalls.scm | 4 ++++ 2 files changed, 10 insertions(+), 4 deletions(-) (limited to 'tests/syscalls.scm') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index ed833c10b2..5ce0abbb48 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -915,10 +915,12 @@ (define (fall-back) (catch 'system-error (lambda () - (match (window-size-columns (terminal-window-size port)) - ;; Things like Emacs shell-mode return 0, which is unreasonable. - (0 (fall-back)) - ((? number? columns) columns))) + (if (file-port? port) + (match (window-size-columns (terminal-window-size port)) + ;; Things like Emacs shell-mode return 0, which is unreasonable. + (0 (fall-back)) + ((? number? columns) columns)) + (fall-back))) (lambda args (let ((errno (system-error-errno args))) (if (= errno ENOTTY) diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 1b443be0c8..24ea8f5e60 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -257,4 +257,8 @@ (define perform-container-tests? (test-assert "terminal-columns" (> (terminal-columns) 0)) +(test-assert "terminal-columns non-file port" + (> (terminal-columns (open-input-string "Join us now, share the software!")) + 0)) + (test-end) -- cgit v1.2.3 From a1f708787d08e567da6118bacc481219884296ca Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 25 Apr 2016 17:18:58 +0200 Subject: syscalls: Add 'statfs'. * guix/build/syscalls.scm (): New record type. (fsword): New macro. (%statfs): New C struct. (statfs): New procedure. --- guix/build/syscalls.scm | 71 +++++++++++++++++++++++++++++++++++++++++++++++++ tests/syscalls.scm | 15 +++++++++++ 2 files changed, 86 insertions(+) (limited to 'tests/syscalls.scm') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 468dc7eca2..d168293ee4 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -47,6 +47,20 @@ (define-module (guix build syscalls) mount-points swapon swapoff + + file-system? + file-system-type + file-system-block-size + file-system-block-count + file-system-blocks-free + file-system-blocks-available + file-system-file-count + file-system-free-file-nodes + file-system-identifier + file-system-maximum-name-length + file-system-fragment-size + statfs + processes mkdtemp! pivot-root @@ -457,6 +471,63 @@ (define mkdtemp! (list err))) (pointer->string result))))) + +(define-record-type + (file-system type block-size blocks blocks-free + blocks-available files free-files identifier + name-length fragment-size + spare0 spare1 spare2) + file-system? + (type file-system-type) + (block-size file-system-block-size) + (blocks file-system-block-count) + (blocks-free file-system-blocks-free) + (blocks-available file-system-blocks-available) + (files file-system-file-count) + (free-files file-system-free-file-nodes) + (identifier file-system-identifier) + (name-length file-system-maximum-name-length) + (fragment-size file-system-fragment-size) + (spare0 file-system--spare0) + (spare1 file-system--spare1) + (spare2 file-system--spare2)) + +(define-syntax fsword ;fsword_t + (identifier-syntax long)) + +(define-c-struct %statfs + sizeof-statfs ;slightly overestimated + file-system + read-statfs + write-statfs! + (type fsword) + (block-size fsword) + (blocks uint64) + (blocks-free uint64) + (blocks-available uint64) + (files uint64) + (free-files uint64) + (identifier uint64) ;really "int[2]" + (name-length fsword) + (fragment-size fsword) + (spare0 int128) ;really "fsword[4]" + (spare1 int128) + (spare2 int64)) ;XXX: to match array alignment + +(define statfs + (let ((proc (syscall->procedure int "statfs" '(* *)))) + (lambda (file) + "Return a data structure describing the file system +mounted at FILE." + (let* ((stat (make-bytevector sizeof-statfs)) + (ret (proc (string->pointer file) (bytevector->pointer stat))) + (err (errno))) + (if (zero? ret) + (read-statfs stat 0) + (throw 'system-error "statfs" "~A: ~A" + (list file (strerror err)) + (list err))))))) + ;;; ;;; Containers. diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 24ea8f5e60..895f90f4d8 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -78,6 +78,21 @@ (define-module (test-syscalls) (rmdir dir) #t)))) +(test-equal "statfs, ENOENT" + ENOENT + (catch 'system-error + (lambda () + (statfs "/does-not-exist")) + (compose system-error-errno list))) + +(test-assert "statfs" + (let ((fs (statfs "/"))) + (and (file-system? fs) + (> (file-system-block-size fs) 0) + (>= (file-system-blocks-available fs) 0) + (>= (file-system-blocks-free fs) + (file-system-blocks-available fs))))) + (define (user-namespace pid) (string-append "/proc/" (number->string pid) "/ns/user")) -- cgit v1.2.3 From 5cd25aad3cdb6c970a76542e328a3beba8c1f2c9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 25 Apr 2016 23:22:45 +0200 Subject: syscalls: 'terminal-columns' catches EINVAL on the TIOCGWINSZ ioctl. Reported by Mark H Weaver . * guix/build/syscalls.scm (terminal-columns): Tolerate EINVAL. * tests/syscalls.scm ("terminal-window-size ENOTTY"): Likewise. --- guix/build/syscalls.scm | 5 ++++- tests/syscalls.scm | 7 ++++--- 2 files changed, 8 insertions(+), 4 deletions(-) (limited to 'tests/syscalls.scm') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index d168293ee4..6cdf65304d 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1034,7 +1034,10 @@ (define (fall-back) (fall-back))) (lambda args (let ((errno (system-error-errno args))) - (if (= errno ENOTTY) + ;; ENOTTY is what we're after but 2012-and-earlier Linux versions + ;; would return EINVAL instead in some cases: + ;; . + (if (or (= errno ENOTTY) (= errno EINVAL)) (fall-back) (apply throw args)))))) diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 895f90f4d8..71bcbc4d32 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -259,15 +259,16 @@ (define perform-container-tests? (#f #f) (lo (interface-address lo))))))) -(test-equal "terminal-window-size ENOTTY" - ENOTTY +(test-assert "terminal-window-size ENOTTY" (call-with-input-file "/dev/null" (lambda (port) (catch 'system-error (lambda () (terminal-window-size port)) (lambda args - (system-error-errno args)))))) + ;; Accept EINVAL, which some old Linux versions might return. + (memv (system-error-errno args) + (list ENOTTY EINVAL))))))) (test-assert "terminal-columns" (> (terminal-columns) 0)) -- cgit v1.2.3 From ae4ff9f359514937878cf82f4ac46dd14aac9056 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 May 2016 23:59:05 +0200 Subject: syscalls: Add 'tcgetattr' and 'tcsetattr' bindings. * guix/build/syscalls.scm (bits->symbols-body, define-bits) (local-flags): New macros. (TCSANOW, TCSADRAIN, TCSAFLUSH): New variables. (): New record type. (%termios): New C structure. (tcgetattr, tcsetattr): New procedures. * tests/syscalls.scm ("tcgetattr ENOTTY", "tcgetattr") ("tcsetattr"): New tests. --- guix/build/syscalls.scm | 131 ++++++++++++++++++++++++++++++++++++++++++++++++ tests/syscalls.scm | 25 +++++++++ 2 files changed, 156 insertions(+) (limited to 'tests/syscalls.scm') 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 @@ (define-module (guix build syscalls) 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 @@ (define free-ifaddrs ;;; 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 +(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 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 ; + 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 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 + (($ 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 ; (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 @@ (define perform-container-tests? (#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) -- cgit v1.2.3