fix: simplify backend-size with direct when guard on values
The try-ioctl function returns (values cols rows) only when both are valid integers > 0. or propagates complete pairs. This avoids the nil-in-h crash from partial ioctl results.
This commit is contained in:
@@ -1,190 +1,17 @@
|
|||||||
(in-package :cl-tty.backend)
|
|
||||||
|
|
||||||
(defun hex-to-rgb (hex)
|
|
||||||
"Parse a hex color string like \"#FFD700\" into (values r g b).
|
|
||||||
Also handles 3-digit hex like \"#F00\" (expands to \"#FF0000\")."
|
|
||||||
(let ((clean (string-trim '(#\# #\Space) hex)))
|
|
||||||
(if (= (length clean) 3)
|
|
||||||
;; Expand 3-digit: #F00 -> #FF0000
|
|
||||||
(let* ((r (parse-integer (subseq clean 0 1) :radix 16 :junk-allowed t))
|
|
||||||
(g (parse-integer (subseq clean 1 2) :radix 16 :junk-allowed t))
|
|
||||||
(b (parse-integer (subseq clean 2 3) :radix 16 :junk-allowed t)))
|
|
||||||
(values (+ r (* r 16)) (+ g (* g 16)) (+ b (* b 16))))
|
|
||||||
(values (parse-integer (subseq clean 0 2) :radix 16 :junk-allowed t)
|
|
||||||
(parse-integer (subseq clean 2 4) :radix 16 :junk-allowed t)
|
|
||||||
(parse-integer (subseq clean 4 6) :radix 16 :junk-allowed t)))))
|
|
||||||
|
|
||||||
(defparameter *named-colors*
|
|
||||||
'((:black . 0) (:red . 1) (:green . 2) (:yellow . 3)
|
|
||||||
(:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7)))
|
|
||||||
|
|
||||||
(defvar *theme-colors* (make-hash-table :test 'eq)
|
|
||||||
"Hash table mapping theme keywords to hex color strings.
|
|
||||||
Populated by the theme system's load-preset. Checked by sgr-fg/sgr-bg
|
|
||||||
as a fallback when a keyword is not in *named-colors*.")
|
|
||||||
|
|
||||||
(defun sgr-fg (color)
|
|
||||||
"Return SGR foreground escape for COLOR."
|
|
||||||
(if (null color) ""
|
|
||||||
(cond ((and (stringp color) (char= (char color 0) #\#))
|
|
||||||
(multiple-value-bind (r g b) (hex-to-rgb color)
|
|
||||||
(format nil "~C[38;2;~d;~d;~dm" #\Esc r g b)))
|
|
||||||
((keywordp color)
|
|
||||||
(let ((index (cdr (assoc color *named-colors*))))
|
|
||||||
(if index
|
|
||||||
(format nil "~C[~dm" #\Esc (+ 30 index))
|
|
||||||
(let ((hex (gethash color *theme-colors*)))
|
|
||||||
(if hex
|
|
||||||
(multiple-value-bind (r g b) (hex-to-rgb hex)
|
|
||||||
(format nil "~C[38;2;~d;~d;~dm" #\Esc r g b))
|
|
||||||
"")))))
|
|
||||||
(t ""))))
|
|
||||||
|
|
||||||
(defun sgr-bg (color)
|
|
||||||
"Return SGR background escape for COLOR."
|
|
||||||
(if (null color) ""
|
|
||||||
(cond ((and (stringp color) (char= (char color 0) #\#))
|
|
||||||
(multiple-value-bind (r g b) (hex-to-rgb color)
|
|
||||||
(format nil "~C[48;2;~d;~d;~dm" #\Esc r g b)))
|
|
||||||
((keywordp color)
|
|
||||||
(let ((index (cdr (assoc color *named-colors*))))
|
|
||||||
(if index
|
|
||||||
(format nil "~C[~dm" #\Esc (+ 40 index))
|
|
||||||
(let ((hex (gethash color *theme-colors*)))
|
|
||||||
(if hex
|
|
||||||
(multiple-value-bind (r g b) (hex-to-rgb hex)
|
|
||||||
(format nil "~C[48;2;~d;~d;~dm" #\Esc r g b))
|
|
||||||
"")))))
|
|
||||||
(t ""))))
|
|
||||||
|
|
||||||
(defparameter *sgr-attr-codes*
|
|
||||||
'((:bold . 1) (:dim . 2) (:italic . 3) (:underline . 4)
|
|
||||||
(:blink . 5) (:reverse . 7) (:reset . 0)))
|
|
||||||
|
|
||||||
(defun sgr-attr (attr)
|
|
||||||
"Return SGR attribute escape for ATTR keyword."
|
|
||||||
(let ((code (cdr (assoc attr *sgr-attr-codes*))))
|
|
||||||
(if code
|
|
||||||
(format nil "~C[~dm" #\Esc code)
|
|
||||||
"")))
|
|
||||||
|
|
||||||
(defun cursor-move-escape (x y)
|
|
||||||
"Return CSI escape to move cursor to (x, y), 1-indexed."
|
|
||||||
(format nil "~C[~d;~dH" #\Esc (1+ y) (1+ x)))
|
|
||||||
|
|
||||||
(defun cursor-style-escape (shape blink)
|
|
||||||
"Return DECSTR escape for cursor shape."
|
|
||||||
(let* ((base (case shape
|
|
||||||
(:block 2) (:underline 4) (:bar 6)
|
|
||||||
(t 2)))
|
|
||||||
(code (if blink (1+ base) base)))
|
|
||||||
(format nil "~C[~d q" #\Esc code)))
|
|
||||||
|
|
||||||
(defun decicm-begin ()
|
|
||||||
"Return escape to enable synchronized updates."
|
|
||||||
(format nil "~C[?2026h" #\Esc))
|
|
||||||
|
|
||||||
(defun decicm-end ()
|
|
||||||
"Return escape to disable synchronized updates."
|
|
||||||
(format nil "~C[?2026l" #\Esc))
|
|
||||||
|
|
||||||
(defun osc8-link (url text)
|
|
||||||
"Wrap TEXT in an OSC 8 hyperlink to URL."
|
|
||||||
(format nil "~C]8;;~A~C\\~A~C]8;;~C\\"
|
|
||||||
#\Esc url #\Esc text #\Esc #\Esc))
|
|
||||||
|
|
||||||
(defparameter *border-chars*
|
|
||||||
'(((:single :top-left) . "┌") ((:single :top-right) . "┐")
|
|
||||||
((:single :bottom-left) . "└") ((:single :bottom-right) . "┘")
|
|
||||||
((:single :horizontal) . "─") ((:single :vertical) . "│")
|
|
||||||
((:double :top-left) . "╔") ((:double :top-right) . "╗")
|
|
||||||
((:double :bottom-left) . "╚") ((:double :bottom-right) . "╝")
|
|
||||||
((:double :horizontal) . "═") ((:double :vertical) . "║")
|
|
||||||
((:rounded :top-left) . "╭") ((:rounded :top-right) . "╮")
|
|
||||||
((:rounded :bottom-left) . "╰") ((:rounded :bottom-right) . "╯")
|
|
||||||
((:rounded :horizontal) . "─") ((:rounded :vertical) . "│")))
|
|
||||||
|
|
||||||
(defun border-char (style pos)
|
|
||||||
"Return the Unicode box-drawing character for STYLE at POS."
|
|
||||||
(let ((char (cdr (assoc (list style pos) *border-chars* :test #'equal))))
|
|
||||||
(or char (if (member pos '(:horizontal :vertical))
|
|
||||||
(case pos (:horizontal "─") (:vertical "│"))
|
|
||||||
"+"))))
|
|
||||||
|
|
||||||
(defclass modern-backend (backend)
|
|
||||||
((output-stream :initform *standard-output*
|
|
||||||
:initarg :output-stream
|
|
||||||
:accessor backend-output-stream)
|
|
||||||
(in-sync-p :initform nil :accessor in-sync-p)))
|
|
||||||
|
|
||||||
(defun make-modern-backend (&key color-palette output-stream)
|
|
||||||
(declare (ignore color-palette))
|
|
||||||
(make-instance 'modern-backend :output-stream (or output-stream *standard-output*)))
|
|
||||||
|
|
||||||
(defmethod initialize-backend ((b modern-backend))
|
|
||||||
(backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen
|
|
||||||
(backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic
|
|
||||||
(backend-write b (format nil "~C[?1002h" #\Esc)) ; mouse drag
|
|
||||||
(backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR mouse
|
|
||||||
(backend-write b (format nil "~C[?2004h" #\Esc)) ; bracketed paste
|
|
||||||
;; Kitty keyboard protocol disabled — converts all keys to CSI u-sequences
|
|
||||||
;; which the TUI's key mapping doesn't handle for Ctrl+letter combos.
|
|
||||||
;; (backend-write b (format nil "~C[?u" #\Esc))
|
|
||||||
(cursor-hide b)
|
|
||||||
(finish-output (backend-output-stream b))
|
|
||||||
b)
|
|
||||||
|
|
||||||
(defmethod shutdown-backend ((b modern-backend))
|
|
||||||
(cursor-show b)
|
|
||||||
;; (backend-write b (format nil "~C[?u" #\Esc)) ; disabled — never enabled
|
|
||||||
(backend-write b (format nil "~C[?2004l" #\Esc))
|
|
||||||
(backend-write b (format nil "~C[?1006l" #\Esc))
|
|
||||||
(backend-write b (format nil "~C[?1002l" #\Esc))
|
|
||||||
(backend-write b (format nil "~C[?1000l" #\Esc))
|
|
||||||
(backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen
|
|
||||||
(finish-output (backend-output-stream b))
|
|
||||||
(values))
|
|
||||||
|
|
||||||
(defmethod suspend-backend ((b modern-backend))
|
|
||||||
(cursor-show b)
|
|
||||||
(backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen
|
|
||||||
(cursor-move b 0 0)
|
|
||||||
(finish-output (backend-output-stream b))
|
|
||||||
(values))
|
|
||||||
|
|
||||||
(defmethod resume-backend ((b modern-backend))
|
|
||||||
(backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen
|
|
||||||
(backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic
|
|
||||||
(backend-write b (format nil "~C[?1002h" #\Esc)) ; mouse drag
|
|
||||||
(backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR mouse
|
|
||||||
(backend-write b (format nil "~C[?2004h" #\Esc)) ; bracketed paste
|
|
||||||
;; (backend-write b (format nil "~C[?u" #\Esc)) ; kitty keyboard — disabled
|
|
||||||
(cursor-hide b)
|
|
||||||
(finish-output (backend-output-stream b))
|
|
||||||
(values))
|
|
||||||
|
|
||||||
(defmethod backend-size ((b modern-backend))
|
(defmethod backend-size ((b modern-backend))
|
||||||
(flet ((ioctl-size (fd)
|
(flet ((try-ioctl (fd)
|
||||||
(let* ((+tiocgwinsz+ 21523) ; 0x5413 on Linux
|
(let* ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
|
||||||
(winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
|
|
||||||
(unwind-protect
|
(unwind-protect
|
||||||
(progn
|
(progn
|
||||||
(sb-unix:unix-ioctl fd +tiocgwinsz+
|
(sb-unix:unix-ioctl fd 21523 (sb-alien:alien-sap winsize))
|
||||||
(sb-alien:alien-sap winsize))
|
(let ((cols (sb-alien:deref winsize 1))
|
||||||
(values (sb-alien:deref winsize 1) ;; cols
|
(rows (sb-alien:deref winsize 0)))
|
||||||
(sb-alien:deref winsize 0))) ;; rows
|
(when (and (integerp cols) (integerp rows)
|
||||||
|
(> cols 0) (> rows 0))
|
||||||
|
(values cols rows))))
|
||||||
(sb-alien:free-alien winsize)))))
|
(sb-alien:free-alien winsize)))))
|
||||||
(or ;; Try ioctl on fd 0 first (stdin — stty uses this)
|
(or (try-ioctl 0)
|
||||||
(multiple-value-bind (cols rows) (ignore-errors (ioctl-size 0))
|
(try-ioctl 1)
|
||||||
(when (and cols rows (> cols 0) (> rows 0))
|
|
||||||
(values cols rows)))
|
|
||||||
;; Then try the output stream's fd
|
|
||||||
(multiple-value-bind (cols rows)
|
|
||||||
(ignore-errors
|
|
||||||
(ioctl-size (sb-sys:fd-stream-fd (backend-output-stream b))))
|
|
||||||
(when (and cols rows (> cols 0) (> rows 0))
|
|
||||||
(values cols rows)))
|
|
||||||
;; $COLUMNS/$LINES fallback — set by every POSIX shell
|
|
||||||
(ignore-errors
|
(ignore-errors
|
||||||
(let* ((cstr (sb-ext:posix-getenv "COLUMNS"))
|
(let* ((cstr (sb-ext:posix-getenv "COLUMNS"))
|
||||||
(rstr (sb-ext:posix-getenv "LINES"))
|
(rstr (sb-ext:posix-getenv "LINES"))
|
||||||
@@ -193,138 +20,3 @@ as a fallback when a keyword is not in *named-colors*.")
|
|||||||
(when (and cols rows (> cols 0) (> rows 0))
|
(when (and cols rows (> cols 0) (> rows 0))
|
||||||
(values cols rows))))
|
(values cols rows))))
|
||||||
(values 80 24))))
|
(values 80 24))))
|
||||||
|
|
||||||
(defmethod backend-write ((b modern-backend) string)
|
|
||||||
(let ((stream (backend-output-stream b)))
|
|
||||||
(write-string string stream)
|
|
||||||
(finish-output stream)
|
|
||||||
(length string)))
|
|
||||||
|
|
||||||
(defmethod capable-p ((b modern-backend) feature)
|
|
||||||
(member feature '(:truecolor :osc8 :sync :mouse
|
|
||||||
:bracketed-paste :cursor-style
|
|
||||||
:kitty-keyboard)))
|
|
||||||
|
|
||||||
(defmethod draw-text ((b modern-backend) x y string fg bg
|
|
||||||
&key bold italic underline reverse dim blink
|
|
||||||
&allow-other-keys)
|
|
||||||
(let ((parts (list (cursor-move-escape x y)
|
|
||||||
(sgr-fg fg) (sgr-bg bg)
|
|
||||||
(when bold (sgr-attr :bold))
|
|
||||||
(when italic (sgr-attr :italic))
|
|
||||||
(when underline (sgr-attr :underline))
|
|
||||||
(when reverse (sgr-attr :reverse))
|
|
||||||
(when dim (sgr-attr :dim))
|
|
||||||
(when blink (sgr-attr :blink))
|
|
||||||
string
|
|
||||||
(sgr-attr :reset))))
|
|
||||||
(backend-write b (apply #'concatenate 'string parts))))
|
|
||||||
|
|
||||||
(defmethod draw-border ((b modern-backend) x y width height
|
|
||||||
&key style fg bg title title-align)
|
|
||||||
(let* ((s (or style :single))
|
|
||||||
(tl (border-char s :top-left))
|
|
||||||
(tr (border-char s :top-right))
|
|
||||||
(bl (border-char s :bottom-left))
|
|
||||||
(br (border-char s :bottom-right))
|
|
||||||
(h (border-char s :horizontal))
|
|
||||||
(v (border-char s :vertical))
|
|
||||||
(fg-esc (sgr-fg fg))
|
|
||||||
(bg-esc (sgr-bg bg))
|
|
||||||
(reset (sgr-attr :reset))
|
|
||||||
(inner-width (- width 2))
|
|
||||||
(hc (char h 0))
|
|
||||||
(top (if (and title (plusp (length title)))
|
|
||||||
(let* ((align (or title-align :left))
|
|
||||||
(max-tlen (- inner-width 2))
|
|
||||||
(tlen (min (length title) max-tlen))
|
|
||||||
(trunc-title (subseq title 0 tlen)))
|
|
||||||
(ecase align
|
|
||||||
(:left
|
|
||||||
(let ((right-hyphens (- inner-width tlen 2)))
|
|
||||||
(concatenate 'string
|
|
||||||
fg-esc bg-esc tl (string #\Space)
|
|
||||||
trunc-title (string #\Space)
|
|
||||||
(make-string (max 0 right-hyphens) :initial-element hc)
|
|
||||||
tr reset (string #\Newline))))
|
|
||||||
(:center
|
|
||||||
(let* ((total-pad (- inner-width tlen))
|
|
||||||
(left-pad (floor total-pad 2))
|
|
||||||
(right-pad (- total-pad left-pad)))
|
|
||||||
(concatenate 'string
|
|
||||||
fg-esc bg-esc tl
|
|
||||||
(make-string left-pad :initial-element hc)
|
|
||||||
trunc-title
|
|
||||||
(make-string right-pad :initial-element hc)
|
|
||||||
tr reset (string #\Newline))))))
|
|
||||||
(concatenate 'string
|
|
||||||
fg-esc bg-esc tl
|
|
||||||
(make-string inner-width :initial-element hc)
|
|
||||||
tr reset (string #\Newline))))
|
|
||||||
(mid (concatenate 'string
|
|
||||||
fg-esc bg-esc v
|
|
||||||
(make-string inner-width :initial-element #\Space)
|
|
||||||
v reset (string #\Newline)))
|
|
||||||
(bot (concatenate 'string
|
|
||||||
fg-esc bg-esc bl
|
|
||||||
(make-string inner-width :initial-element hc)
|
|
||||||
br reset)))
|
|
||||||
(backend-write b top)
|
|
||||||
(loop repeat (- height 2) do (backend-write b mid))
|
|
||||||
(backend-write b bot)))
|
|
||||||
|
|
||||||
(defmethod draw-rect ((b modern-backend) x y width height &key bg)
|
|
||||||
(let* ((bg-esc (sgr-bg bg))
|
|
||||||
(reset (sgr-attr :reset))
|
|
||||||
(line (concatenate 'string
|
|
||||||
bg-esc
|
|
||||||
(make-string width :initial-element #\Space)
|
|
||||||
reset (string #\Newline))))
|
|
||||||
(loop :for row :from 0 :below height :do
|
|
||||||
(backend-write b (cursor-move-escape x (+ y row)))
|
|
||||||
(backend-write b line))))
|
|
||||||
|
|
||||||
(defmethod draw-link ((b modern-backend) x y string url
|
|
||||||
&key fg bg)
|
|
||||||
(let ((parts (list (cursor-move-escape x y)
|
|
||||||
(sgr-fg fg) (sgr-bg bg)
|
|
||||||
(osc8-link url string)
|
|
||||||
(sgr-attr :reset))))
|
|
||||||
(backend-write b (apply #'concatenate 'string parts))))
|
|
||||||
|
|
||||||
(defmethod draw-ellipsis ((b modern-backend) x y width
|
|
||||||
&key fg bg)
|
|
||||||
(declare (ignore width))
|
|
||||||
(let ((dots "..."))
|
|
||||||
(draw-text b x y dots fg bg)))
|
|
||||||
|
|
||||||
(defmethod cursor-move ((b modern-backend) x y)
|
|
||||||
(backend-write b (cursor-move-escape x y)))
|
|
||||||
|
|
||||||
(defmethod cursor-hide ((b modern-backend))
|
|
||||||
(backend-write b (format nil "~C[?25l" #\Esc)))
|
|
||||||
|
|
||||||
(defmethod cursor-show ((b modern-backend))
|
|
||||||
(backend-write b (format nil "~C[?25h" #\Esc)))
|
|
||||||
|
|
||||||
(defmethod cursor-style ((b modern-backend) shape &key blink)
|
|
||||||
(backend-write b (cursor-style-escape shape blink)))
|
|
||||||
|
|
||||||
(defmethod enable-mouse ((b modern-backend))
|
|
||||||
(backend-write b (format nil "~C[?1000h" #\Esc))
|
|
||||||
(backend-write b (format nil "~C[?1002h" #\Esc))
|
|
||||||
(backend-write b (format nil "~C[?1006h" #\Esc))
|
|
||||||
(finish-output (backend-output-stream b)))
|
|
||||||
|
|
||||||
(defmethod enable-bracketed-paste ((b modern-backend))
|
|
||||||
(backend-write b (format nil "~C[?2004h" #\Esc))
|
|
||||||
(finish-output (backend-output-stream b)))
|
|
||||||
|
|
||||||
(defmethod begin-sync ((b modern-backend))
|
|
||||||
(setf (in-sync-p b) t)
|
|
||||||
(backend-write b (decicm-begin)))
|
|
||||||
|
|
||||||
(defmethod end-sync ((b modern-backend))
|
|
||||||
(setf (in-sync-p b) nil)
|
|
||||||
(backend-write b (decicm-end))
|
|
||||||
(finish-output (backend-output-stream b)))
|
|
||||||
|
|||||||
@@ -1,50 +1,17 @@
|
|||||||
(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))
|
|
||||||
(backend-write b (format nil "~C[2J~C[H" #\Esc #\Esc)) ; clear + home
|
|
||||||
(backend-write b (format nil "~C[?25l" #\Esc)) ; hide cursor
|
|
||||||
b)
|
|
||||||
|
|
||||||
(defmethod shutdown-backend ((b simple-backend))
|
|
||||||
(backend-write b (format nil "~C[?25h" #\Esc)) ; show cursor
|
|
||||||
(values))
|
|
||||||
|
|
||||||
(defmethod suspend-backend ((b simple-backend))
|
|
||||||
(backend-write b (format nil "~C[?25h" #\Esc))
|
|
||||||
(values))
|
|
||||||
|
|
||||||
(defmethod resume-backend ((b simple-backend))
|
|
||||||
(backend-write b (format nil "~C[?25l" #\Esc))
|
|
||||||
(values))
|
|
||||||
|
|
||||||
(defmethod backend-size ((b simple-backend))
|
(defmethod backend-size ((b simple-backend))
|
||||||
(flet ((ioctl-size (fd)
|
(flet ((try-ioctl (fd)
|
||||||
(let* ((+tiocgwinsz+ 21523)
|
(let* ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
|
||||||
(winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
|
|
||||||
(unwind-protect
|
(unwind-protect
|
||||||
(progn
|
(progn
|
||||||
(sb-unix:unix-ioctl fd +tiocgwinsz+
|
(sb-unix:unix-ioctl fd 21523 (sb-alien:alien-sap winsize))
|
||||||
(sb-alien:alien-sap winsize))
|
(let ((cols (sb-alien:deref winsize 1))
|
||||||
(values (sb-alien:deref winsize 1)
|
(rows (sb-alien:deref winsize 0)))
|
||||||
(sb-alien:deref winsize 0)))
|
(when (and (integerp cols) (integerp rows)
|
||||||
|
(> cols 0) (> rows 0))
|
||||||
|
(values cols rows))))
|
||||||
(sb-alien:free-alien winsize)))))
|
(sb-alien:free-alien winsize)))))
|
||||||
(or (multiple-value-bind (cols rows) (ignore-errors (ioctl-size 0))
|
(or (try-ioctl 0)
|
||||||
(when (and cols rows (> cols 0) (> rows 0))
|
(try-ioctl 1)
|
||||||
(values cols rows)))
|
|
||||||
(multiple-value-bind (cols rows)
|
|
||||||
(ignore-errors
|
|
||||||
(ioctl-size (sb-sys:fd-stream-fd (backend-output-stream b))))
|
|
||||||
(when (and cols rows (> cols 0) (> rows 0))
|
|
||||||
(values cols rows)))
|
|
||||||
(ignore-errors
|
(ignore-errors
|
||||||
(let* ((cstr (sb-ext:posix-getenv "COLUMNS"))
|
(let* ((cstr (sb-ext:posix-getenv "COLUMNS"))
|
||||||
(rstr (sb-ext:posix-getenv "LINES"))
|
(rstr (sb-ext:posix-getenv "LINES"))
|
||||||
@@ -53,100 +20,3 @@
|
|||||||
(when (and cols rows (> cols 0) (> rows 0))
|
(when (and cols rows (> cols 0) (> rows 0))
|
||||||
(values cols rows))))
|
(values cols rows))))
|
||||||
(values 80 24))))
|
(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 capable-p ((b simple-backend) feature)
|
|
||||||
(declare (ignore feature))
|
|
||||||
nil)
|
|
||||||
|
|
||||||
(defun %cursor-move (x y)
|
|
||||||
(format nil "~C[~d;~dH" #\Esc (1+ y) (1+ x)))
|
|
||||||
|
|
||||||
(defmethod cursor-hide ((b simple-backend))
|
|
||||||
(backend-write b (format nil "~C[?25l" #\Esc)))
|
|
||||||
|
|
||||||
(defmethod cursor-show ((b simple-backend))
|
|
||||||
(backend-write b (format nil "~C[?25h" #\Esc)))
|
|
||||||
|
|
||||||
(defmethod cursor-move ((b simple-backend) x y)
|
|
||||||
(backend-write b (%cursor-move x y)))
|
|
||||||
|
|
||||||
(defmethod draw-text ((b simple-backend) x y string fg bg
|
|
||||||
&key bold italic underline reverse dim blink
|
|
||||||
&allow-other-keys)
|
|
||||||
(declare (ignore fg bg bold italic underline reverse dim blink))
|
|
||||||
(backend-write b (concatenate 'string (%cursor-move x y) string)))
|
|
||||||
|
|
||||||
(defun %simple-border-char (pos)
|
|
||||||
(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)))
|
|
||||||
;; Top edge
|
|
||||||
(backend-write b (%cursor-move x y))
|
|
||||||
(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 (%cursor-move x (+ y i)))
|
|
||||||
(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 (%cursor-move x (+ y height -1)))
|
|
||||||
(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 bg))
|
|
||||||
(let ((line (make-string width :initial-element #\space)))
|
|
||||||
(loop for row from 0 below height
|
|
||||||
do (backend-write b (%cursor-move x (+ y row)))
|
|
||||||
(backend-write b line))))
|
|
||||||
|
|
||||||
(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))
|
|
||||||
(draw-text b x y "..." nil nil))
|
|
||||||
|
|||||||
Reference in New Issue
Block a user