Amr Gharbeia
21c7b1c2d9
stty size returns incomplete data when run through uiop:run-program (the child may not have terminal access). tput is a terminfo utility that outputs a single number per call, avoiding parsing issues. Works reliably in any subprocess context.
159 lines
6.4 KiB
Common Lisp
159 lines
6.4 KiB
Common Lisp
(in-package :cl-tty.backend)
|
|
|
|
(defclass simple-backend (backend)
|
|
((output-stream :initform *standard-output*
|
|
:initarg :output-stream
|
|
:accessor backend-output-stream)))
|
|
|
|
(defun make-simple-backend (&key output-stream)
|
|
(make-instance 'simple-backend
|
|
:output-stream (or output-stream *standard-output*)))
|
|
|
|
(defmethod initialize-backend ((b simple-backend))
|
|
b)
|
|
|
|
(defmethod shutdown-backend ((b simple-backend))
|
|
(values))
|
|
|
|
(defmethod suspend-backend ((b simple-backend))
|
|
(values))
|
|
|
|
(defmethod resume-backend ((b simple-backend))
|
|
(values))
|
|
|
|
(defmethod backend-size ((b simple-backend))
|
|
(or ;; tput cols / tput lines via subprocess
|
|
(multiple-value-bind (cols rows)
|
|
(values
|
|
(ignore-errors
|
|
(parse-integer
|
|
(string-trim '(#\newline #\space)
|
|
(uiop:run-program '("tput" "cols") :output :string
|
|
:ignore-error-status t))))
|
|
(ignore-errors
|
|
(parse-integer
|
|
(string-trim '(#\newline #\space)
|
|
(uiop:run-program '("tput" "lines") :output :string
|
|
:ignore-error-status t)))))
|
|
(when (and cols rows (> cols 0) (> rows 0))
|
|
(values cols rows)))
|
|
;; ioctl on stdout fd — fast, correct after SIGWINCH at runtime.
|
|
(multiple-value-bind (cols rows)
|
|
(ignore-errors
|
|
(let* ((+tiocgwinsz+ 21523)
|
|
(winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
|
|
(unwind-protect
|
|
(progn
|
|
(sb-unix:unix-ioctl (sb-sys:fd-stream-fd
|
|
(backend-output-stream b))
|
|
+tiocgwinsz+
|
|
(sb-alien:alien-sap winsize))
|
|
(values (sb-alien:deref winsize 1)
|
|
(sb-alien:deref winsize 0)))
|
|
(sb-alien:free-alien winsize))))
|
|
(when (and cols rows (> cols 0) (> rows 0))
|
|
(values cols rows)))
|
|
(ignore-errors
|
|
(let ((tty-fd (sb-unix:unix-open "/dev/tty" 0 0))) ; O_RDONLY
|
|
(when (and tty-fd (numberp tty-fd) (> tty-fd 0))
|
|
(unwind-protect
|
|
(let* ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
|
|
(sb-unix:unix-ioctl tty-fd 21523 (sb-alien:alien-sap winsize))
|
|
(let ((cols (sb-alien:deref winsize 1))
|
|
(rows (sb-alien:deref winsize 0)))
|
|
(sb-alien:free-alien winsize)
|
|
(when (and (integerp cols) (integerp rows)
|
|
(> cols 0) (> rows 0))
|
|
(values cols rows))))
|
|
(sb-unix:unix-close tty-fd)))))
|
|
(values 80 24)))
|
|
|
|
(defmethod backend-write ((b simple-backend) string)
|
|
(let ((stream (backend-output-stream b)))
|
|
(write-string string stream)
|
|
(finish-output stream)
|
|
(length string)))
|
|
|
|
(defmethod draw-text ((b simple-backend) x y string fg bg
|
|
&key bold italic underline reverse dim blink
|
|
&allow-other-keys)
|
|
(declare (ignore x y fg bg bold italic underline reverse dim blink))
|
|
(backend-write b string))
|
|
|
|
(defun %simple-border-char (pos)
|
|
"Return ASCII border character at POS.
|
|
POS is :top-left, :top-right, :bottom-left, :bottom-right,
|
|
:horizontal, or :vertical."
|
|
(case pos
|
|
((:top-left :top-right :bottom-left :bottom-right) #\+)
|
|
(:horizontal #\-)
|
|
(:vertical #\|)))
|
|
|
|
(defmethod draw-border ((b simple-backend) x y width height
|
|
&key style fg bg title title-align)
|
|
(declare (ignore style fg bg))
|
|
(let ((h (%simple-border-char :horizontal))
|
|
(v (%simple-border-char :vertical))
|
|
(tl (%simple-border-char :top-left))
|
|
(tr (%simple-border-char :top-right))
|
|
(bl (%simple-border-char :bottom-left))
|
|
(br (%simple-border-char :bottom-right)))
|
|
;; Position cursor with newlines and spaces (no escape sequences)
|
|
(dotimes (row y) (backend-write b (string #\Newline)))
|
|
;; Top edge with optional title
|
|
(backend-write b (make-string x :initial-element #\space))
|
|
(backend-write b (string tl))
|
|
(if (and title (plusp (length title)))
|
|
(let* ((align (or title-align :left))
|
|
(inner-width (- width 2))
|
|
(max-tlen (- inner-width 2))
|
|
(tlen (min (length title) max-tlen))
|
|
(trunc-title (subseq title 0 tlen)))
|
|
(ecase align
|
|
(:left
|
|
(backend-write b (string #\Space))
|
|
(backend-write b trunc-title)
|
|
(backend-write b (string #\Space))
|
|
(backend-write b (make-string (- inner-width tlen 2) :initial-element h)))
|
|
(:center
|
|
(let* ((total-pad (- inner-width tlen))
|
|
(left-pad (floor total-pad 2))
|
|
(right-pad (- total-pad left-pad)))
|
|
(backend-write b (make-string left-pad :initial-element h))
|
|
(backend-write b trunc-title)
|
|
(backend-write b (make-string right-pad :initial-element h))))))
|
|
(backend-write b (make-string (- width 2) :initial-element h)))
|
|
(backend-write b (string tr))
|
|
;; Sides
|
|
(loop for i from 1 below (1- height)
|
|
do (backend-write b (string #\Newline))
|
|
(backend-write b (make-string x :initial-element #\space))
|
|
(backend-write b (string v))
|
|
(backend-write b (make-string (- width 2) :initial-element #\space))
|
|
(backend-write b (string v)))
|
|
;; Bottom edge
|
|
(backend-write b (string #\Newline))
|
|
(backend-write b (make-string x :initial-element #\space))
|
|
(backend-write b (string bl))
|
|
(backend-write b (make-string (- width 2) :initial-element h))
|
|
(backend-write b (string br))))
|
|
|
|
(defmethod draw-rect ((b simple-backend) x y width height
|
|
&key bg)
|
|
(declare (ignore x y width height bg))
|
|
;; On simple backend, background fill is a no-op
|
|
(values))
|
|
|
|
(defmethod draw-link ((b simple-backend) x y string url
|
|
&key fg bg)
|
|
(declare (ignore url fg bg))
|
|
(draw-text b x y string nil nil))
|
|
|
|
(defmethod draw-ellipsis ((b simple-backend) x y width
|
|
&key fg bg)
|
|
(declare (ignore width fg bg))
|
|
;; Position using newlines+spaces (simple-backend pattern)
|
|
(dotimes (row y) (backend-write b (string #\Newline)))
|
|
(backend-write b (make-string x :initial-element #\Space))
|
|
(backend-write b "..."))
|