Bindings/Lisp/brlapi.lisp - brltty - Git at Google

 ;;;; libbrlapi - A library providing access to braille terminals for applications.
 ;;;;
 ;;;; Copyright (C) 2006-2023 by Mario Lang <mlang@delysid.org>
 ;;;;
 ;;;; libbrlapi comes with ABSOLUTELY NO WARRANTY.
 ;;;;
 ;;;; This is free software, placed under the terms of the
 ;;;; GNU Lesser General Public License, as published by the Free Software
 ;;;; Foundation; either version 2.1 of the License, or (at your option) any
 ;;;; later version. Please see the file LICENSE-LGPL for details.
 ;;;;
 ;;;; Web Page: http://brltty.app/
 ;;;;
 ;;;; This software is maintained by Dave Mielke <dave@mielke.cc>.

 (eval-when (:compile-toplevel)
   (declaim (optimize (safety 3) (debug 3))))

 (in-package :brlapi)

 ;;;; * The DISPLAY class

 (defclass display ()
   ((handle :initarg :handle :reader connection-handle)
    (fd :initarg :fd :reader file-descriptor)
    (auth :initarg :auth :reader server-auth)
    (host :initarg :host :reader server-host)
    (tty :initform nil :reader entered-tty)))

 (defmethod property-list ((obj display))
   "Return various properties as a lsit of three-element lists.
 The sublist for each returned property contains, in order, its name, its value, and its format string."
   (list*
     (list "version" (multiple-value-list (library-version)) "~{~D~^.~}")
     (if (is-connected obj)
       (multiple-value-bind (width height) (display-size obj)
         (list
           (list "host" (server-host obj) "~A")
           (list "auth" (server-auth obj) "~A")
           (list "fd" (file-descriptor obj) "~D")
           (list "driver" (driver-name obj) "~A")
           (list "model" (model-identifier obj) "~A")
           (list "width" width "~D")
           (list "height" height "~D")
         )
       )
     )
   )
 )

 (defmethod print-object ((obj display) stream)
   (print-unreadable-object (obj stream :type t)
     (format stream "~{~A~^ ~}"
       (loop
         for (name value format) in (property-list obj) by #'cdr
         append (list (format nil "~A=~@?" name format value))
       )
     )
   )
 )


 ;;;; * Error handling

 (defctype brlapi-code :int)
 (define-condition brlapi-error (error)
   ((text :initarg :text :reader brlapi-error-text))
   (:report (lambda (c stream)
              (format stream "libbrlapi function returned ~A"
                      (brlapi-error-text c))))
   (:documentation "Signalled when a libbrlapi function answers with -1."))

 (defmethod error-message ()
   "The message for the most recent error."
   (foreign-funcall "brlapi_strerror"
     :pointer (foreign-funcall "brlapi_error_location" :pointer)
     :string)
 )

 (defmethod translate-from-foreign (value (name (eql 'brlapi-code)))
   "Raise a BRLAPI-ERROR if VALUE, a brlapi-code, is -1."
   (declare (integer value))
   (if (eql value -1)
       (error 'brlapi-error :text (error-message))
       value))


 ;;;; * Connection management

 (defmethod is-connected ((obj display))
   (and
     obj
     (let
       ((fd (file-descriptor obj)))
       (and fd (numberp fd) (not (< fd 0)))
     )
   )
 )

 (defcstruct settings
   "Connection setting structure."
   (auth :string)
   (host :string))

 (defun open-connection (&key auth host)
   "Open a new connection to BRLTTY on HOST usng AUTH for authorization.
 Return a DISPLAY object which can further be used to interact with BRLTTY."
   (with-foreign-object (settings 'settings)
     (setf (foreign-slot-value settings 'settings 'auth)
           (if (stringp auth) auth (null-pointer))
           (foreign-slot-value settings 'settings 'host)
           (if (stringp host) host (null-pointer)))
     (let* ((handle (foreign-alloc :char :count (foreign-funcall "brlapi_getHandleSize" :int)))
            (fd (foreign-funcall "brlapi__openConnection"
                                 :pointer handle
                                 :pointer settings
                                 :pointer settings
                                 brlapi-code))
            (display (make-instance 'display :handle handle :fd fd
                                    :auth (foreign-slot-value settings 'settings 'auth)
                                    :host (foreign-slot-value settings 'settings 'host))))
       #+sbcl (sb-ext:finalize display (lambda ()
                                         (foreign-funcall "brlapi__closeConnection" :pointer handle :void)
                                         (foreign-free handle)))
       display)))

 (defmethod close-connection ((obj display))
   (foreign-funcall "brlapi__closeConnection" :pointer (connection-handle obj) :void)
   (setf (slot-value obj 'fd) nil)
   (foreign-free (connection-handle obj))
   (setf (slot-value obj 'handle) nil))

 ;;;; * Querying the display

 (defmethod library-version ()
   "Return the version of the API as multiple values (major, minor, revision)."
   (with-foreign-objects ((major :int) (minor :int) (revision :int))
     (foreign-funcall "brlapi_getLibraryVersion"
       :pointer major :pointer minor :pointer revision
       :void
     )
     (values (mem-ref major :int) (mem-ref minor :int) (mem-ref revision :int))
   )
 )

 (defmethod driver-name ((obj display))
   "Return the currently used driver name."
   (with-foreign-pointer-as-string ((str str-size) 64)
     (foreign-funcall "brlapi__getDriverName" :pointer (connection-handle obj)
                      :string str :int str-size brlapi-code)))

 (defmethod model-identifier ((obj display))
   "Return the currently used display model."
   (with-foreign-pointer-as-string ((str str-size) 64)
     (foreign-funcall "brlapi__getModelIdentifier" :pointer (connection-handle obj)
                      :string str :int str-size brlapi-code)))

 (defmethod display-size ((obj display))
   "Return the dimensions of DISPLAY as multiple values.
 The first value represents the x dimension and the second the y dimension."
   (with-foreign-objects ((x :int) (y :int))
     (foreign-funcall "brlapi__getDisplaySize" :pointer (connection-handle obj) :pointer x :pointer y brlapi-code)
     (values (mem-ref x :int) (mem-ref y :int))))

 ;;;; * TTY mode

 (defmethod enter-tty-mode ((obj display) tty &optional (driver ""))
   (declare (integer tty))
   (declare (string driver))
   (setf (slot-value obj 'tty) (foreign-funcall "brlapi__enterTtyMode" :pointer (connection-handle obj) :int tty :string driver brlapi-code)))

 (defmethod leave-tty-mode ((obj display))
   (foreign-funcall "brlapi__leaveTtyMode" :pointer (connection-handle obj) brlapi-code)
   (setf (slot-value obj 'tty) nil))


 ;;;; * Output

 (defmethod write-text ((obj display) text &key (cursor -1))
   "Write TEXT (a string) to the braille display."
   (declare (string text))
   (declare (integer cursor))
   (if (eql (foreign-funcall "brlapi__writeText"
                             :pointer (connection-handle obj)
                             :int cursor :string text
                             brlapi-code)
            0)
       text))

 (defbitfield (dots :uint8)
   (:dot1 #x01) :dot2 :dot3 :dot4 :dot5 :dot6 :dot7 :dot8)
 (defmethod write-dots ((obj display) &rest dots-list)
   "Write the given dots list to the display."
   (with-foreign-object (dots 'dots (display-size obj))
     (loop for i below (min (display-size obj) (length dots-list))
           do (setf (mem-aref dots 'dots i)
                    (foreign-bitfield-value 'dots (nth i dots-list))))
     (loop for i from (length dots-list) below (display-size obj)
           do (setf (mem-aref dots 'dots i) 0))
     (foreign-funcall "brlapi__writeDots" :pointer (connection-handle obj) :pointer dots brlapi-code)))

 (defcstruct write-struct
   (display-number :int)
   (region-begin :int)
   (region-size :int)
   (text :pointer)
   (attr-and :pointer)
   (attr-or :pointer)
   (cursor :int)
   (charset :string))

 (defmethod write-region ((obj display) text &key (begin 1) size (cursor -1) (display-number -1)
                          (charset "") attr-and attr-or)
   "Update a specific region of the braille display and apply and/or masks."
   (let ((size (or size (min (display-size obj)
                             (max (length text)
                                  (length attr-and)
                                  (length attr-or))))))
     (with-foreign-objects ((ws 'write-struct)
                            (txt :string (1+ size))
                            (attra 'dots size)
                            (attro 'dots size))
       (loop for i below size
             do (setf (mem-aref txt :uint8 i) (char-code #\SPACE)))
       (setf (mem-aref txt :uint8 size) 0)
       (loop for i below (min size (length text))
             do (setf (mem-aref txt :uint8 i) (char-code (aref text i))))
       (loop for i below size
             do (setf (mem-aref attra :uint8 i) #XFF (mem-aref attro :uint8 i) 0))
       (loop for i below (min size (length attr-and))
             do (setf (mem-aref attra :uint8 i) (foreign-bitfield-value 'dots (nth i attr-and))))
       (loop for i below (min size (length attr-or))
             do (setf (mem-aref attro :uint8 i) (foreign-bitfield-value 'dots (nth i attr-or))))
       (setf (foreign-slot-value ws 'write-struct 'display-number) display-number
             (foreign-slot-value ws 'write-struct 'cursor) cursor
             (foreign-slot-value ws 'write-struct 'region-begin) begin
             (foreign-slot-value ws 'write-struct 'region-size) size
             (foreign-slot-value ws 'write-struct 'charset) charset
             (foreign-slot-value ws 'write-struct 'text) txt
             (foreign-slot-value ws 'write-struct 'attr-or) attro
             (foreign-slot-value ws 'write-struct 'attr-and) attra)
       (eql (foreign-funcall "brlapi__write" :pointer (connection-handle obj) :pointer ws brlapi-code) 0))))


 ;;;; * Input

 (defctype key-code :uint64)
 (defmethod read-key ((obj display) &optional block)
   (with-foreign-object (key 'key-code)
     (case (foreign-funcall "brlapi__readKey" :pointer (connection-handle obj) :boolean block :pointer key brlapi-code)
       (0 nil)
       (1 (mem-ref key 'key-code)))))

 (defmethod read-key-with-timeout ((obj display) &optional (timeout -1))
   (with-foreign-object (key 'key-code)
     (case (foreign-funcall "brlapi__readKeyWithTimeout" :pointer (connection-handle obj) :int (* timeout 1000) :pointer key brlapi-code)
       (0 nil)
       (1 (mem-ref key 'key-code)))))

 (defcstruct expanded-key-code
   "A key code broken down into its individual fields."
   (type :int)
   (command :int)
   (argument :int)
   (flags :int)
 )

 (defcstruct key-code-description
   "The description of a key code."
   (type-name :string)
   (command-name :string)
   (argument-value :int)
   (flag-count :int)
   (flag-names :string :count 32)
   (field-values expanded-key-code)
 )

 (defun expand-key-code (code)
   "Return the individual fields of a key code as a list of numeric values.
 The list contains, in order, the type, command, argument, and flags."

   (with-foreign-object (expansion 'expanded-key-code)
     (foreign-funcall "brlapi_expandKeyCode" key-code code :pointer expansion :int)
     (with-foreign-slots
       ((type command argument flags) expansion expanded-key-code)
       (list type command argument flags)
     )
   )
 )

 (defun describe-key-code (code)
   "Return the individual fields of the key code as a list.
 The list contains:
   0: type (a string)
   1: command (a string)
   2: argument (a non-negative integer)
   3: flags (a list of strings)"

   (with-foreign-object (description 'key-code-description)
     (foreign-funcall "brlapi_describeKeyCode" key-code code :pointer description :int)
     (with-foreign-slots
       ((type-name command-name argument-value flag-count flag-names) description key-code-description)

       (list
         type-name command-name argument-value
         (loop
           for index below flag-count
           collect (mem-aref (foreign-slot-pointer description 'key-code-description 'flag-names) :string index))
       )
     )
   )
 )

 ;;;; * Example usage

 (defun example (&optional (tty -1))
   "A basic example."
   (let ((display (open-connection)))
     (enter-tty-mode display tty)
     (write-text display "Press any key to continue...")
     (apply #'format t "; Command: ~A, argument: ~D, flags: ~D"
            (multiple-value-list (expand-key-code (read-key display t))))
     (leave-tty-mode display)
     (close-connection display)))
	;;;; libbrlapi - A library providing access to braille terminals for applications.
	;;;;
	;;;; Copyright (C) 2006-2023 by Mario Lang <mlang@delysid.org>
	;;;;
	;;;; libbrlapi comes with ABSOLUTELY NO WARRANTY.
	;;;;
	;;;; This is free software, placed under the terms of the
	;;;; GNU Lesser General Public License, as published by the Free Software
	;;;; Foundation; either version 2.1 of the License, or (at your option) any
	;;;; later version. Please see the file LICENSE-LGPL for details.
	;;;;
	;;;; Web Page: http://brltty.app/
	;;;;
	;;;; This software is maintained by Dave Mielke <dave@mielke.cc>.

	(eval-when (:compile-toplevel)
	(declaim (optimize (safety 3) (debug 3))))

	(in-package :brlapi)

	;;;; * The DISPLAY class

	(defclass display ()
	((handle :initarg :handle :reader connection-handle)
	(fd :initarg :fd :reader file-descriptor)
	(auth :initarg :auth :reader server-auth)
	(host :initarg :host :reader server-host)
	(tty :initform nil :reader entered-tty)))

	(defmethod property-list ((obj display))
	"Return various properties as a lsit of three-element lists.
	The sublist for each returned property contains, in order, its name, its value, and its format string."
	(list*
	(list "version" (multiple-value-list (library-version)) "~{~D~^.~}")
	(if (is-connected obj)
	(multiple-value-bind (width height) (display-size obj)
	(list
	(list "host" (server-host obj) "~A")
	(list "auth" (server-auth obj) "~A")
	(list "fd" (file-descriptor obj) "~D")
	(list "driver" (driver-name obj) "~A")
	(list "model" (model-identifier obj) "~A")
	(list "width" width "~D")
	(list "height" height "~D")
	)
	)
	)
	)
	)

	(defmethod print-object ((obj display) stream)
	(print-unreadable-object (obj stream :type t)
	(format stream "~{~A~^ ~}"
	(loop
	for (name value format) in (property-list obj) by #'cdr
	append (list (format nil "~A=~@?" name format value))
	)
	)
	)
	)


	;;;; * Error handling

	(defctype brlapi-code :int)
	(define-condition brlapi-error (error)
	((text :initarg :text :reader brlapi-error-text))
	(:report (lambda (c stream)
	(format stream "libbrlapi function returned ~A"
	(brlapi-error-text c))))
	(:documentation "Signalled when a libbrlapi function answers with -1."))

	(defmethod error-message ()
	"The message for the most recent error."
	(foreign-funcall "brlapi_strerror"
	:pointer (foreign-funcall "brlapi_error_location" :pointer)
	:string)
	)

	(defmethod translate-from-foreign (value (name (eql 'brlapi-code)))
	"Raise a BRLAPI-ERROR if VALUE, a brlapi-code, is -1."
	(declare (integer value))
	(if (eql value -1)
	(error 'brlapi-error :text (error-message))
	value))


	;;;; * Connection management

	(defmethod is-connected ((obj display))
	(and
	obj
	(let
	((fd (file-descriptor obj)))
	(and fd (numberp fd) (not (< fd 0)))
	)
	)
	)

	(defcstruct settings
	"Connection setting structure."
	(auth :string)
	(host :string))

	(defun open-connection (&key auth host)
	"Open a new connection to BRLTTY on HOST usng AUTH for authorization.
	Return a DISPLAY object which can further be used to interact with BRLTTY."
	(with-foreign-object (settings 'settings)
	(setf (foreign-slot-value settings 'settings 'auth)
	(if (stringp auth) auth (null-pointer))
	(foreign-slot-value settings 'settings 'host)
	(if (stringp host) host (null-pointer)))
	(let* ((handle (foreign-alloc :char :count (foreign-funcall "brlapi_getHandleSize" :int)))
	(fd (foreign-funcall "brlapi__openConnection"
	:pointer handle
	:pointer settings
	:pointer settings
	brlapi-code))
	(display (make-instance 'display :handle handle :fd fd
	:auth (foreign-slot-value settings 'settings 'auth)
	:host (foreign-slot-value settings 'settings 'host))))
	#+sbcl (sb-ext:finalize display (lambda ()
	(foreign-funcall "brlapi__closeConnection" :pointer handle :void)
	(foreign-free handle)))
	display)))

	(defmethod close-connection ((obj display))
	(foreign-funcall "brlapi__closeConnection" :pointer (connection-handle obj) :void)
	(setf (slot-value obj 'fd) nil)
	(foreign-free (connection-handle obj))
	(setf (slot-value obj 'handle) nil))

	;;;; * Querying the display

	(defmethod library-version ()
	"Return the version of the API as multiple values (major, minor, revision)."
	(with-foreign-objects ((major :int) (minor :int) (revision :int))
	(foreign-funcall "brlapi_getLibraryVersion"
	:pointer major :pointer minor :pointer revision
	:void
	)
	(values (mem-ref major :int) (mem-ref minor :int) (mem-ref revision :int))
	)
	)

	(defmethod driver-name ((obj display))
	"Return the currently used driver name."
	(with-foreign-pointer-as-string ((str str-size) 64)
	(foreign-funcall "brlapi__getDriverName" :pointer (connection-handle obj)
	:string str :int str-size brlapi-code)))

	(defmethod model-identifier ((obj display))
	"Return the currently used display model."
	(with-foreign-pointer-as-string ((str str-size) 64)
	(foreign-funcall "brlapi__getModelIdentifier" :pointer (connection-handle obj)
	:string str :int str-size brlapi-code)))

	(defmethod display-size ((obj display))
	"Return the dimensions of DISPLAY as multiple values.
	The first value represents the x dimension and the second the y dimension."
	(with-foreign-objects ((x :int) (y :int))
	(foreign-funcall "brlapi__getDisplaySize" :pointer (connection-handle obj) :pointer x :pointer y brlapi-code)
	(values (mem-ref x :int) (mem-ref y :int))))

	;;;; * TTY mode

	(defmethod enter-tty-mode ((obj display) tty &optional (driver ""))
	(declare (integer tty))
	(declare (string driver))
	(setf (slot-value obj 'tty) (foreign-funcall "brlapi__enterTtyMode" :pointer (connection-handle obj) :int tty :string driver brlapi-code)))

	(defmethod leave-tty-mode ((obj display))
	(foreign-funcall "brlapi__leaveTtyMode" :pointer (connection-handle obj) brlapi-code)
	(setf (slot-value obj 'tty) nil))


	;;;; * Output

	(defmethod write-text ((obj display) text &key (cursor -1))
	"Write TEXT (a string) to the braille display."
	(declare (string text))
	(declare (integer cursor))
	(if (eql (foreign-funcall "brlapi__writeText"
	:pointer (connection-handle obj)
	:int cursor :string text
	brlapi-code)
	0)
	text))

	(defbitfield (dots :uint8)
	(:dot1 #x01) :dot2 :dot3 :dot4 :dot5 :dot6 :dot7 :dot8)
	(defmethod write-dots ((obj display) &rest dots-list)
	"Write the given dots list to the display."
	(with-foreign-object (dots 'dots (display-size obj))
	(loop for i below (min (display-size obj) (length dots-list))
	do (setf (mem-aref dots 'dots i)
	(foreign-bitfield-value 'dots (nth i dots-list))))
	(loop for i from (length dots-list) below (display-size obj)
	do (setf (mem-aref dots 'dots i) 0))
	(foreign-funcall "brlapi__writeDots" :pointer (connection-handle obj) :pointer dots brlapi-code)))

	(defcstruct write-struct
	(display-number :int)
	(region-begin :int)
	(region-size :int)
	(text :pointer)
	(attr-and :pointer)
	(attr-or :pointer)
	(cursor :int)
	(charset :string))

	(defmethod write-region ((obj display) text &key (begin 1) size (cursor -1) (display-number -1)
	(charset "") attr-and attr-or)
	"Update a specific region of the braille display and apply and/or masks."
	(let ((size (or size (min (display-size obj)
	(max (length text)
	(length attr-and)
	(length attr-or))))))
	(with-foreign-objects ((ws 'write-struct)
	(txt :string (1+ size))
	(attra 'dots size)
	(attro 'dots size))
	(loop for i below size
	do (setf (mem-aref txt :uint8 i) (char-code #\SPACE)))
	(setf (mem-aref txt :uint8 size) 0)
	(loop for i below (min size (length text))
	do (setf (mem-aref txt :uint8 i) (char-code (aref text i))))
	(loop for i below size
	do (setf (mem-aref attra :uint8 i) #XFF (mem-aref attro :uint8 i) 0))
	(loop for i below (min size (length attr-and))
	do (setf (mem-aref attra :uint8 i) (foreign-bitfield-value 'dots (nth i attr-and))))
	(loop for i below (min size (length attr-or))
	do (setf (mem-aref attro :uint8 i) (foreign-bitfield-value 'dots (nth i attr-or))))
	(setf (foreign-slot-value ws 'write-struct 'display-number) display-number
	(foreign-slot-value ws 'write-struct 'cursor) cursor
	(foreign-slot-value ws 'write-struct 'region-begin) begin
	(foreign-slot-value ws 'write-struct 'region-size) size
	(foreign-slot-value ws 'write-struct 'charset) charset
	(foreign-slot-value ws 'write-struct 'text) txt
	(foreign-slot-value ws 'write-struct 'attr-or) attro
	(foreign-slot-value ws 'write-struct 'attr-and) attra)
	(eql (foreign-funcall "brlapi__write" :pointer (connection-handle obj) :pointer ws brlapi-code) 0))))


	;;;; * Input

	(defctype key-code :uint64)
	(defmethod read-key ((obj display) &optional block)
	(with-foreign-object (key 'key-code)
	(case (foreign-funcall "brlapi__readKey" :pointer (connection-handle obj) :boolean block :pointer key brlapi-code)
	(0 nil)
	(1 (mem-ref key 'key-code)))))

	(defmethod read-key-with-timeout ((obj display) &optional (timeout -1))
	(with-foreign-object (key 'key-code)
	(case (foreign-funcall "brlapi__readKeyWithTimeout" :pointer (connection-handle obj) :int (* timeout 1000) :pointer key brlapi-code)
	(0 nil)
	(1 (mem-ref key 'key-code)))))

	(defcstruct expanded-key-code
	"A key code broken down into its individual fields."
	(type :int)
	(command :int)
	(argument :int)
	(flags :int)
	)

	(defcstruct key-code-description
	"The description of a key code."
	(type-name :string)
	(command-name :string)
	(argument-value :int)
	(flag-count :int)
	(flag-names :string :count 32)
	(field-values expanded-key-code)
	)

	(defun expand-key-code (code)
	"Return the individual fields of a key code as a list of numeric values.
	The list contains, in order, the type, command, argument, and flags."

	(with-foreign-object (expansion 'expanded-key-code)
	(foreign-funcall "brlapi_expandKeyCode" key-code code :pointer expansion :int)
	(with-foreign-slots
	((type command argument flags) expansion expanded-key-code)
	(list type command argument flags)
	)
	)
	)

	(defun describe-key-code (code)
	"Return the individual fields of the key code as a list.
	The list contains:
	0: type (a string)
	1: command (a string)
	2: argument (a non-negative integer)
	3: flags (a list of strings)"

	(with-foreign-object (description 'key-code-description)
	(foreign-funcall "brlapi_describeKeyCode" key-code code :pointer description :int)
	(with-foreign-slots
	((type-name command-name argument-value flag-count flag-names) description key-code-description)

	(list
	type-name command-name argument-value
	(loop
	for index below flag-count
	collect (mem-aref (foreign-slot-pointer description 'key-code-description 'flag-names) :string index))
	)
	)
	)
	)

	;;;; * Example usage

	(defun example (&optional (tty -1))
	"A basic example."
	(let ((display (open-connection)))
	(enter-tty-mode display tty)
	(write-text display "Press any key to continue...")
	(apply #'format t "; Command: ~A, argument: ~D, flags: ~D"
	(multiple-value-list (expand-key-code (read-key display t))))
	(leave-tty-mode display)
	(close-connection display)))