Move termios bindings to scheme code.

2 files changed, 170 insertions, 14 deletions

diff --git a/module/terminal/escape.scm b/module/terminal/escape.scm
index 8f1b0c2b..a16df594 100644
--- a/module/terminal/escape.scm
+++ b/module/terminal/escape.scm
@@ -3,6 +3,7 @@
 (define-module (terminal escape)
   #:use-module (srfi srfi-60)
   #:use-module (terminal termios)
+  #:use-module (util)
   #:export (with-vulgar))
 
 (define-public (cls)
@@ -15,14 +16,27 @@
 (define-syntax with-vulgar
   (syntax-rules ()
     ((_ thunk)
-     (let ((ifd (fileno (current-input-port)))
-           (ofd (fileno (current-output-port))))
+     (let* ((ifd (current-input-port))
+            (ofd (current-output-port))
+            (iattr (make-termios))
+            (oattr (make-termios))
+            iattr* oattr*)
        (dynamic-wind
          (lambda ()
-           (let ((bits (bitwise-ior ECHO ICANON)))
-             (c-lflags-disable! ifd bits)
-             (c-lflags-disable! ofd bits)))
+           (tcgetattr! iattr ifd)
+           (tcgetattr! oattr ofd)
+
+           ;; Store current settings to enable resetting the terminal later
+           (set! iattr* (copy-termios iattr))
+           (set! oattr* (copy-termios oattr))
+
+           (let ((bits (bitwise-not (bitwise-ior ECHO ICANON))))
+             (set! (lflag iattr) (bitwise-and (lflag iattr) bits))
+             (set! (lflag oattr) (bitwise-and (lflag oattr) bits)))
+
+           (tcsetattr! iattr ifd)
+           (tcsetattr! oattr ofd))
          thunk
          (lambda ()
-           (c-lflag-restore! ifd)
-           (c-lflag-restore! ofd))))  )))
+           (tcsetattr! iattr* ifd)
+           (tcsetattr! oattr* ofd)))))))
diff --git a/module/terminal/termios.scm b/module/terminal/termios.scm
index 50683f84..77e6ecf0 100644
--- a/module/terminal/termios.scm
+++ b/module/terminal/termios.scm
@@ -1,13 +1,155 @@
 ;;; Module for termios interaction from Guile,
 ;;; Since that for some reason isn't built in.
+;; /usr/include/bits/termios.h
 
 (define-module (terminal termios)
-  #:export (c-lflags-disable! c-lflag-restore!))
+  :use-module (system foreign)
+  :use-module (ice-9 format)
+  :use-module (ice-9 rdelim)
+  :use-module (srfi srfi-9)             ; records
+  :use-module (util)
+  :export (make-termios
+           copy-termios
+           tcsetattr! tcgetattr! cfmakeraw!))
 
-(define-public ECHO	#x0000010)
-(define-public ICANON	#x0000002)
+
 
-(setenv "LD_LIBRARY_PATH"
-        (string-append (dirname (dirname (dirname (current-filename))))
-                       "/lib"))
-(load-extension "libtermios" "init_termios")
+;;; Constants, TODO, auto parse these from
+;; /usr/include/bits/termios.h
+
+(define-public ECHO	0000010)
+(define-public ICANON	0000002)
+
+;; @var{when} values
+(define-public TCSANOW   0)
+(define-public TCSADRAIN 1)
+(define-public TCSAFLUSH 2)
+
+
+
+;; Create the @code{#$} reader macro for creating C bindings.
+;; For example
+;; @example
+;; #$ tcgetattr : int, * → int
+;; @end example
+;; would create a binding to a C function called tcgetattr, with the type
+;; int, * → int, and bind it to a scheme procedure of the same name.
+;; 
+;; Currently only links to the library stored in the variable lib, when called.
+(eval-when (compile)
+ (read-hash-extend
+  #\$ (lambda (c port)
+        (let* ((name (string-trim-both (read-delimited ":" port)))
+               (input (read-delimited "→" port))
+               (out (string->symbol (string-trim-both (read-line port)))))
+          `(define ,(string->symbol name)
+             (pointer->procedure
+              ,out (dynamic-func ,name lib)
+              (list
+               ,@(map (lambda (symb)  (if (eq? symb '*) (quote '*) symb))
+                      (map (compose string->symbol string-trim-both)
+                           (string-split input #\,))))))))))
+
+
+
+
+(define (empty-values struct-type)
+  (cond ((null? struct-type) '())
+        ((list? struct-type)
+         (cons (empty-values (car struct-type))
+               (empty-values (cdr struct-type))))
+        (else 0)))
+
+
+
+(define struct-termios
+  (let ((cc-t uint8)
+        (speed-t unsigned-int)
+        (tcflag-t unsigned-int)
+        (NCCS 32))
+   (list tcflag-t tcflag-t tcflag-t tcflag-t
+         cc-t (make-list NCCS cc-t)
+         speed-t speed-t)))
+
+
+;; Representation of a termios struct. @var{ptr} should always hold a valid
+;; reference to a C object, and @var{list} should hold a parsed version of the
+;; same data.
+(define-record-type <termios>
+  (%make-termios ptr list)
+  termios?
+  (ptr as-ptr)
+  (list as-list))
+
+(define* (make-termios #:optional (data (empty-values struct-termios)))
+  (%make-termios (make-c-struct struct-termios data) data))
+
+(define (copy-termios termios)
+  (let ((lst (as-list termios)))
+   (%make-termios (make-c-struct struct-termios lst) lst)))
+
+;; Sets the pointer value in termios directly. Also parses the data and sets the list.
+(define (set-ptr! t v)
+  ((record-modifier <termios> 'ptr)  t v)
+  ((record-modifier <termios> 'list) t (parse-c-struct v struct-termios)))
+
+;; Sets the list value in termios directly. Also creates a C struct of the data
+;; and stores that.
+(define (set-list! t v)
+  ((record-modifier <termios> 'list) t v)
+  ((record-modifier <termios> 'ptr) t (make-c-struct struct-termios v)))
+
+;; TODO {i,o}speed should be looked up in a table.
+;; TODO bit fields should display what their fields mean
+((@ (srfi srfi-9 gnu) set-record-type-printer!)
+ <termios>
+ (lambda (t p)
+   (format p "#<termios iflag=~b oflag=~b cflag=~b lflag=~b line=~d ispeed=~d ospeed=~d cc=~s>"
+           (iflag t) (oflag t) (cflag t) (lflag t) (line t) (ispeed t) (ospeed t)
+           (map integer->char (filter (negate zero?) (cc t))))))
+
+
+
+;; Macro for creating accessor bindings for slots in a list, which are wrapped
+;; inside a <termios> record. Called exactly once below.
+(define-macro (create-bindings! . symbols)
+  `(begin ,@(map-each
+             (lambda (symb i)
+               `(define-public ,symb
+                  (make-procedure-with-setter
+                   (lambda (t) (list-ref (as-list t) ,i))
+                   (lambda (t v) (let ((lst (as-list t)))
+                              (list-set! lst ,i v)
+                              (set-list! t lst))))))
+             symbols)))
+
+(create-bindings! ; accessors
+ iflag oflag cflag lflag line cc ispeed ospeed)
+
+
+
+;; TODO this should possibly use unwind guards
+(define (with-ptr termios proc)
+  (let ((ptr (as-ptr termios)))
+    (let ((ret (proc ptr)))
+      (set-ptr! termios ptr)
+      ret)))
+
+
+
+(define-once lib (dynamic-link))
+
+#$ tcsetattr : int, int, * → int
+(define* (tcsetattr! termios  #:optional
+                     (port (current-input-port))
+                     (when TCSANOW))
+  (with-ptr termios (lambda (ptr) (tcsetattr (port->fdes port) when ptr))))
+
+
+#$ tcgetattr : int, * → int
+(define* (tcgetattr! termios #:optional (port (current-input-port)))
+  (with-ptr termios (lambda (ptr) (tcgetattr (port->fdes port) ptr))))
+
+#$ cfmakeraw : * → int
+(define* (cfmakeraw! termios)
+  (with-ptr termios cfmakeraw))