613e4b6217
The -F flag isn't available on all stty implementations. Using shell stdin redirect (stty ... < /dev/tty) via /bin/sh is more portable and doesn't depend on run-program preserving the controlling terminal across subprocess boundaries.
308 lines
14 KiB
Common Lisp
308 lines
14 KiB
Common Lisp
(in-package #:cl-tty.input)
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Utility: split-string (avoids external dependency)
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun %split-string (string separator)
|
|
"Split STRING at each occurrence of SEPARATOR. Returns list of strings."
|
|
(loop with start = 0
|
|
for pos = (position separator string :start start)
|
|
collect (subseq string start pos)
|
|
while pos
|
|
do (setf start (1+ pos))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Global variables for rendering pipeline (set by application)
|
|
;;; ---------------------------------------------------------------------------
|
|
(defvar *current-backend* nil
|
|
"The active backend used for rendering.")
|
|
(defvar *current-theme* nil
|
|
"The active theme used for semantic color resolution.")
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Key event struct
|
|
;;; ---------------------------------------------------------------------------
|
|
(defstruct key-event
|
|
(key nil :type (or keyword null))
|
|
(ctrl nil :type boolean)
|
|
(alt nil :type boolean)
|
|
(shift nil :type boolean)
|
|
(code nil :type (or fixnum null))
|
|
(raw nil :type (or string null))
|
|
(text nil :type (or string null)))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Mouse event struct
|
|
;;; ---------------------------------------------------------------------------
|
|
(defstruct mouse-event
|
|
(type nil :type (or keyword null))
|
|
(button nil :type (or keyword nil))
|
|
(x 0 :type fixnum)
|
|
(y 0 :type fixnum)
|
|
(raw nil :type (or string null)))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Terminal raw mode (stty on /dev/tty — portable across Unices)
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun stty-run (args)
|
|
"Run stty with ARGS. Returns stdout as string."
|
|
(with-output-to-string (s)
|
|
(sb-ext:run-program "/bin/sh"
|
|
(list "-c" (format nil "stty ~{~a~^ ~} < /dev/tty"
|
|
(mapcar #'princ-to-string args)))
|
|
:output s :wait t)))
|
|
|
|
(defun save-terminal-state ()
|
|
"Save current terminal settings via stty -g. Returns a string."
|
|
(let ((s (string-trim '(#\Newline #\Space) (stty-run '("-g")))))
|
|
(when (zerop (length s))
|
|
(error "stty -g failed — not running in a real terminal"))
|
|
s))
|
|
|
|
(defun set-raw-mode ()
|
|
"Put terminal in raw mode via stty. Returns the saved state string."
|
|
(let ((saved (save-terminal-state)))
|
|
(stty-run '("raw" "-echo" "-isig" "-icanon" "min" "1" "time" "0"))
|
|
saved))
|
|
|
|
(defun restore-terminal-state (saved)
|
|
"Restore saved terminal state (a string from stty -g, or nil)."
|
|
(when (and saved (plusp (length saved)))
|
|
(stty-run (list saved))))
|
|
|
|
(defmacro with-raw-terminal (&body body)
|
|
(let ((saved (gensym "SAVED")))
|
|
`(let ((,saved (save-terminal-state)))
|
|
(set-raw-mode)
|
|
(unwind-protect
|
|
(progn ,@body)
|
|
(restore-terminal-state ,saved)))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Low-level byte reading
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun read-raw-byte (&key timeout)
|
|
(flet ((read-one ()
|
|
(let ((buf (make-array 1 :element-type '(unsigned-byte 8))))
|
|
;; Use sb-sys:with-pinned-objects so sb-posix:read can access the buffer
|
|
(sb-sys:with-pinned-objects (buf)
|
|
(let ((n (sb-posix:read 0 (sb-sys:vector-sap buf) 1)))
|
|
(when (plusp n)
|
|
(return-from read-raw-byte (aref buf 0))))))))
|
|
(if timeout
|
|
(let ((deadline (+ (get-universal-time) timeout)))
|
|
(loop while (< (get-universal-time) deadline)
|
|
do (handler-case
|
|
(read-one)
|
|
(sb-posix:syscall-error ()
|
|
(return-from read-raw-byte nil)))
|
|
(sleep 0.01))
|
|
nil)
|
|
(handler-case
|
|
(read-one)
|
|
(sb-posix:syscall-error (e)
|
|
(format *error-output* "read error: ~A~%" e)
|
|
nil)))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; CSI parameter parser
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun parse-csi-params ()
|
|
(let ((params '())
|
|
(raw (make-array 0 :element-type '(unsigned-byte 8)
|
|
:fill-pointer 0 :adjustable t))
|
|
(current 0))
|
|
(loop
|
|
(let ((b (read-raw-byte)))
|
|
(unless b (return (values nil nil nil)))
|
|
(vector-push-extend b raw)
|
|
(cond
|
|
((and (>= b #x30) (<= b #x3f))
|
|
(if (char= (code-char b) #\;)
|
|
(progn (push current params) (setf current 0))
|
|
;; Non-digit parameter characters (< = > ?) start a new param at zero
|
|
(if (member b '(#x3c #x3d #x3e #x3f) :test #'=)
|
|
(setf current 0)
|
|
(setf current (+ (* current 10) (- b #x30))))))
|
|
((and (>= b #x20) (<= b #x2f))
|
|
nil)
|
|
((and (>= b #x40) (<= b #x7e))
|
|
(push current params)
|
|
(return (values (nreverse params) b
|
|
(map 'string #'code-char raw))))
|
|
(t
|
|
(return (values nil nil nil))))))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Key event tables
|
|
;;; ---------------------------------------------------------------------------
|
|
(defparameter *csi-key-table*
|
|
'((#\A . :up) (#\B . :down) (#\C . :right) (#\D . :left)
|
|
(#\F . :end) (#\H . :home)
|
|
(#\P . :f1) (#\Q . :f2) (#\R . :f3) (#\S . :f4)
|
|
(#\Z . :tab)))
|
|
|
|
(defparameter *csi-tilde-table*
|
|
'((1 . :home) (2 . :insert) (3 . :delete)
|
|
(4 . :end) (5 . :page-up) (6 . :page-down)
|
|
(7 . :home) (8 . :end)
|
|
(11 . :f1) (12 . :f2) (13 . :f3) (14 . :f4)
|
|
(15 . :f5) (17 . :f6) (18 . :f7) (19 . :f8)
|
|
(20 . :f9) (21 . :f10) (23 . :f11) (24 . :f12)))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; SGR mouse parser
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun parse-sgr-mouse (raw)
|
|
(let* ((start (position #\< raw))
|
|
(end (position #\m raw :from-end t))
|
|
(end2 (position #\M raw :from-end t))
|
|
(final (if end end end2))
|
|
(releasep (char= (char raw (1- (length raw))) #\m)))
|
|
(when (and start final (> final start))
|
|
(let* ((nums (mapcar #'parse-integer
|
|
(%split-string (subseq raw (1+ start) final) #\;)))
|
|
(code (first nums))
|
|
(x (or (second nums) 0))
|
|
(y (or (third nums) 0))
|
|
(button (logand code #x03))
|
|
(mod (logand code #x1c))
|
|
(motion (logand code #x20))
|
|
(wheel (logand code #x40)))
|
|
(declare (ignore mod))
|
|
(make-mouse-event
|
|
:type (cond (releasep :release)
|
|
(motion :drag)
|
|
(t :press))
|
|
:button (cond (wheel (if (zerop (logand code #x01))
|
|
:wheel-up :wheel-down))
|
|
((= button 0) :left)
|
|
((= button 1) :middle)
|
|
((= button 2) :right)
|
|
(t :none))
|
|
:x x :y y :raw raw)))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Escape sequence reader
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun %read-escape-sequence ()
|
|
(let ((b (read-raw-byte)))
|
|
(unless b
|
|
(return-from %read-escape-sequence
|
|
(make-key-event :key :escape :raw (string #\Esc))))
|
|
(case b
|
|
;; SS3: ESC O X
|
|
(#x4f
|
|
(let ((b2 (read-raw-byte)))
|
|
(if b2
|
|
(let ((key (cdr (assoc (code-char b2)
|
|
'((#\P . :f1) (#\Q . :f2)
|
|
(#\R . :f3) (#\S . :f4))))))
|
|
(make-key-event :key (or key :unknown)
|
|
:raw (format nil "~C~C~C" #\Esc #\O (code-char b2))))
|
|
(make-key-event :key :escape :raw (string #\Esc)))))
|
|
;; CSI: ESC [ ...
|
|
(#x5b
|
|
(multiple-value-bind (params final-byte raw) (parse-csi-params)
|
|
(if (null final-byte)
|
|
(make-key-event :key :escape :raw (string #\Esc))
|
|
;; SGR mouse: ESC [ < ... m/M
|
|
(if (and raw (plusp (length raw)) (char= (char raw 0) #\<))
|
|
(or (parse-sgr-mouse raw)
|
|
(make-key-event :key :unknown :raw raw))
|
|
(if (and (char= (code-char final-byte) #\M)
|
|
(>= (length params) 3))
|
|
(let* ((p0 (first params)))
|
|
(if (zerop (logand p0 #x40))
|
|
(let* ((x (second params))
|
|
(y (third params))
|
|
(button (logand p0 #x03))
|
|
(motion (logand p0 #x20))
|
|
(release (= button 3)))
|
|
(make-mouse-event
|
|
:type (cond (release :release)
|
|
(motion :drag)
|
|
(t :press))
|
|
:button (let ((b button)) (cond ((= b 0) :left) ((= b 1) :middle) ((= b 2) :right) (t :none)))
|
|
:x x :y y :raw (format nil "~C[<~d;~d;~d~C" #\Esc p0 x y (code-char final-byte))))
|
|
(let* ((tilde-p (char= (code-char final-byte) #\~))
|
|
(param (or p0 0))
|
|
(key (if tilde-p
|
|
(cdr (assoc param *csi-tilde-table*))
|
|
(cdr (assoc (code-char final-byte) *csi-key-table*))))
|
|
(modifier (when (> (length params) 1) (second params))))
|
|
(let ((ctrl nil) (alt nil) (shift nil))
|
|
(when modifier
|
|
(setf shift (logtest modifier 1)
|
|
alt (logtest modifier 2)
|
|
ctrl (logtest modifier 4)))
|
|
(make-key-event :key (or key :unknown)
|
|
:ctrl ctrl :alt alt :shift shift
|
|
:raw (format nil "~C[~d~C" #\Esc param (code-char final-byte))))))
|
|
(let* ((tilde-p (char= (code-char final-byte) #\~))
|
|
(param (or (first params) 0))
|
|
(key (if tilde-p
|
|
(cdr (assoc param *csi-tilde-table*))
|
|
(cdr (assoc (code-char final-byte) *csi-key-table*))))
|
|
(modifier (when (> (length params) 1) (second params))))
|
|
(let ((ctrl nil) (alt nil) (shift nil))
|
|
(when modifier
|
|
(setf shift (logtest modifier 1)
|
|
alt (logtest modifier 2)
|
|
ctrl (logtest modifier 4)))
|
|
(make-key-event :key (or key :unknown)
|
|
:ctrl ctrl :alt alt :shift shift
|
|
:raw (format nil "~C[~d~C" #\Esc param (code-char final-byte)))))))))))
|
|
;; ESC ESC
|
|
(#x1b
|
|
(make-key-event :key :escape :alt t :raw "\\e\\e"))
|
|
;; ESC + printable = Alt+key
|
|
(t
|
|
(let ((ch (code-char b)))
|
|
(if (and (>= b #x20) (<= b #x7e))
|
|
(make-key-event :key (intern (string (string-upcase ch)) :keyword)
|
|
:alt t
|
|
:raw (format nil "~C~C" #\Esc ch))
|
|
(make-key-event :key :unknown
|
|
:raw (format nil "~C~C" #\Esc ch))))))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Top-level event reader
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun %read-event (&key timeout)
|
|
(let ((b (read-raw-byte :timeout timeout)))
|
|
(unless b
|
|
(return-from %read-event nil))
|
|
(cond
|
|
((= b #x1b)
|
|
(%read-escape-sequence))
|
|
((= b #x09)
|
|
(make-key-event :key :tab :code #x09))
|
|
((= b #x0a)
|
|
(make-key-event :key :enter :code #x0a))
|
|
((= b #x0d)
|
|
(make-key-event :key :enter :code #x0d))
|
|
((or (= b #x7f) (= b #x08))
|
|
(make-key-event :key :backspace :code b))
|
|
((and (>= b #x01) (<= b #x1a))
|
|
(let ((key (intern (string-upcase (string (code-char (+ b #x60)))) :keyword)))
|
|
(make-key-event :key key :ctrl t :code b)))
|
|
((= b #x1c) (make-key-event :key :backslash :ctrl t :code b))
|
|
((= b #x1d) (make-key-event :key :rbracket :ctrl t :code b))
|
|
((= b #x1e) (make-key-event :key :caret :ctrl t :code b))
|
|
((= b #x1f) (make-key-event :key :underscore :ctrl t :code b))
|
|
((and (>= b #x20) (<= b #x7e))
|
|
(let ((ch (code-char b)))
|
|
(make-key-event :key (intern (string (string-upcase ch)) :keyword)
|
|
:code b)))
|
|
(t
|
|
(make-key-event :key :unknown :code b :raw (string (code-char b)))))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Backend integration
|
|
;;; ---------------------------------------------------------------------------
|
|
(defmethod read-event ((b cl-tty.backend:backend) &key timeout)
|
|
(declare (ignore b))
|
|
(when (probe-file "/dev/stdin")
|
|
(%read-event :timeout timeout)))
|