From 200dac065492691b4291d5d382f38e2391155091 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 30 Apr 2016 23:30:56 +0200 Subject: syscalls: statfs: Add missing 'mount-flags' field of 'struct statfs'. * guix/build/syscalls.scm ()[mount-flags]: New field. [spare2]: Remove. (%statfs): Likewise. --- guix/build/syscalls.scm | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 6cdf65304d..a85f865180 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -59,6 +59,7 @@ (define-module (guix build syscalls) file-system-identifier file-system-maximum-name-length file-system-fragment-size + file-system-mount-flags statfs processes @@ -475,8 +476,7 @@ (define mkdtemp! (define-record-type (file-system type block-size blocks blocks-free blocks-available files free-files identifier - name-length fragment-size - spare0 spare1 spare2) + name-length fragment-size mount-flags spare0 spare1) file-system? (type file-system-type) (block-size file-system-block-size) @@ -488,14 +488,14 @@ (define-record-type (identifier file-system-identifier) (name-length file-system-maximum-name-length) (fragment-size file-system-fragment-size) + (mount-flags file-system-mount-flags) (spare0 file-system--spare0) - (spare1 file-system--spare1) - (spare2 file-system--spare2)) + (spare1 file-system--spare1)) (define-syntax fsword ;fsword_t (identifier-syntax long)) -(define-c-struct %statfs +(define-c-struct %statfs ; sizeof-statfs ;slightly overestimated file-system read-statfs @@ -510,9 +510,9 @@ (define-c-struct %statfs (identifier uint64) ;really "int[2]" (name-length fsword) (fragment-size fsword) + (mount-flags fsword) (spare0 int128) ;really "fsword[4]" - (spare1 int128) - (spare2 int64)) ;XXX: to match array alignment + (spare1 int128)) (define statfs (let ((proc (syscall->procedure int "statfs" '(* *)))) -- cgit v1.2.3 From 96f2a432bf94c531c4492a46b36fa4836d00a79b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 30 Apr 2016 23:32:25 +0200 Subject: syscalls: 'statfs' explicitly binds 'statfs64'. * guix/build/syscalls.scm (statfs): Explicitly bind "statfs64". --- guix/build/syscalls.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index a85f865180..ed7942c10a 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -515,7 +515,7 @@ (define-c-struct %statfs ; (spare1 int128)) (define statfs - (let ((proc (syscall->procedure int "statfs" '(* *)))) + (let ((proc (syscall->procedure int "statfs64" '(* *)))) (lambda (file) "Return a data structure describing the file system mounted at FILE." @@ -523,7 +523,7 @@ (define statfs (ret (proc (string->pointer file) (bytevector->pointer stat))) (err (errno))) (if (zero? ret) - (read-statfs stat 0) + (read-statfs stat) (throw 'system-error "statfs" "~A: ~A" (list file (strerror err)) (list err))))))) -- cgit v1.2.3 From 00cd41974e9579eccedb948d5eebed442efb600e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 May 2016 21:38:53 +0200 Subject: syscalls: Implement arrays in 'define-c-struct' and use it. * guix/build/syscalls.scm (sizeof*, alignof*, write-type, read-type): Add support for (array ...) forms. * guix/build/syscalls.scm ()[spare0, spare1]: Remove. [spare]: New field. * guix/build/syscalls.scm (%statfs)[identifier]: Change to (array int 2). [spare0, spare1]: Remove. [spare]: New field. --- guix/build/syscalls.scm | 37 +++++++++++++++++++++++++++---------- 1 file changed, 27 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index ed7942c10a..721c590f69 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -123,9 +123,11 @@ (define-module (guix build syscalls) (define-syntax sizeof* ;; XXX: This duplicates 'compile-time-value'. - (syntax-rules (int128) + (syntax-rules (int128 array) ((_ int128) 16) + ((_ (array type n)) + (* (sizeof* type) n)) ((_ type) (let-syntax ((v (lambda (s) (let ((val (sizeof type))) @@ -135,9 +137,11 @@ (define-syntax sizeof* (define-syntax alignof* ;; XXX: This duplicates 'compile-time-value'. - (syntax-rules (int128) + (syntax-rules (int128 array) ((_ int128) 16) + ((_ (array type n)) + (alignof* type)) ((_ type) (let-syntax ((v (lambda (s) (let ((val (alignof type))) @@ -182,10 +186,19 @@ (define-syntax struct-size types ...)))) (define-syntax write-type - (syntax-rules (~) + (syntax-rules (~ array) ((_ bv offset (type ~ order) value) (bytevector-uint-set! bv offset value (endianness order) (sizeof* type))) + ((_ bv offset (array type n) value) + (let loop ((i 0) + (value value) + (o offset)) + (unless (= i n) + (match value + ((head . tail) + (write-type bv o type head) + (loop (+ 1 i) tail (+ o (sizeof* type)))))))) ((_ bv offset type value) (bytevector-uint-set! bv offset value (native-endianness) (sizeof* type))))) @@ -202,7 +215,7 @@ (define-syntax write-types (types ...) (fields ...)))))) (define-syntax read-type - (syntax-rules (~ quote *) + (syntax-rules (~ array quote *) ((_ bv offset '*) (make-pointer (bytevector-uint-ref bv offset (native-endianness) @@ -210,6 +223,12 @@ (define-syntax read-type ((_ bv offset (type ~ order)) (bytevector-uint-ref bv offset (endianness order) (sizeof* type))) + ((_ bv offset (array type n)) + (unfold (lambda (i) (= i n)) + (lambda (i) + (read-type bv (+ offset (* i (sizeof* type))) type)) + 1+ + 0)) ((_ bv offset type) (bytevector-uint-ref bv offset (native-endianness) (sizeof* type))))) @@ -476,7 +495,7 @@ (define mkdtemp! (define-record-type (file-system type block-size blocks blocks-free blocks-available files free-files identifier - name-length fragment-size mount-flags spare0 spare1) + name-length fragment-size mount-flags spare) file-system? (type file-system-type) (block-size file-system-block-size) @@ -489,8 +508,7 @@ (define-record-type (name-length file-system-maximum-name-length) (fragment-size file-system-fragment-size) (mount-flags file-system-mount-flags) - (spare0 file-system--spare0) - (spare1 file-system--spare1)) + (spare file-system--spare)) (define-syntax fsword ;fsword_t (identifier-syntax long)) @@ -507,12 +525,11 @@ (define-c-struct %statfs ; (blocks-available uint64) (files uint64) (free-files uint64) - (identifier uint64) ;really "int[2]" + (identifier (array int 2)) (name-length fsword) (fragment-size fsword) (mount-flags fsword) - (spare0 int128) ;really "fsword[4]" - (spare1 int128)) + (spare (array fsword 4))) (define statfs (let ((proc (syscall->procedure int "statfs64" '(* *)))) -- 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 'guix') 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 From a8f3424b25cbbc585126420bcc1434c4a2398588 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 2 May 2016 08:59:57 +0200 Subject: syscalls: Wrap TCSA* constants in 'tcsetattr-action' macro. * guix/build/syscalls.scm (tcsetattr-action): New macro. (TCSANOW, TCSADRAIN, TCSAFLUSH): Remove. (tcsetattr): Adjust docstring accordingly. * tests/syscalls.scm ("tcsetattr"): Adjust accordingly. --- guix/build/syscalls.scm | 16 ++++++++-------- tests/syscalls.scm | 2 +- 2 files changed, 9 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 4e543d70d8..a9cd6e93c8 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -110,9 +110,7 @@ (define-module (guix build syscalls) termios-input-speed termios-output-speed local-flags - TCSANOW - TCSADRAIN - TCSAFLUSH + tcsetattr-action tcgetattr tcsetattr @@ -1059,9 +1057,11 @@ (define IEXTEN #o0100000) (define EXTPROC #o0200000)) ;; "Actions" values for 'tcsetattr'. -(define TCSANOW 0) -(define TCSADRAIN 1) -(define TCSAFLUSH 2) +(define-bits tcsetattr-action + %unused-tcsetattr-action->symbols + (define TCSANOW 0) + (define TCSADRAIN 1) + (define TCSAFLUSH 2)) (define-record-type (termios input-flags output-flags control-flags local-flags @@ -1107,8 +1107,8 @@ (define tcgetattr (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." + "Use TERMIOS for the tty at FD. ACTIONS is one of of the values +produced by 'tcsetattr-action'; see tcsetattr(3) for details." (define bv (make-bytevector sizeof-termios)) diff --git a/tests/syscalls.scm b/tests/syscalls.scm index ab1e13984d..0b73fb4b0c 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -281,7 +281,7 @@ (define perform-container-tests? (test-assert "tcsetattr" (let ((first (tcgetattr 0))) - (tcsetattr 0 TCSANOW first) + (tcsetattr 0 (tcsetattr-action TCSANOW) first) (equal? first (tcgetattr 0)))) (test-assert "terminal-window-size ENOTTY" -- cgit v1.2.3