mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
1e1256e90b
Failures in red, unexpected success in green. Works on Windows and on terminals with ANSI escape code support. Can be disabled with --no-color.
48 lines
1.4 KiB
Common Lisp
48 lines
1.4 KiB
Common Lisp
|
|
(defun output-handle ()
|
|
(sb-win32::get-std-handle-or-null
|
|
sb-win32::+std-output-handle+))
|
|
|
|
(sb-alien:define-alien-type nil
|
|
(sb-alien:struct console-screen-buffer-info
|
|
(size sb-alien:int)
|
|
(cursor-position sb-alien:int)
|
|
(attributes sb-alien:int)
|
|
(window sb-win32:dword)
|
|
(maximum-window-size sb-alien:int)))
|
|
|
|
(sb-alien:define-alien-routine
|
|
("SetConsoleTextAttribute" set-console-text-attribute)
|
|
sb-alien:boolean
|
|
(console sb-win32:handle)
|
|
(attributes sb-alien:int))
|
|
|
|
(sb-alien:define-alien-routine
|
|
("GetConsoleScreenBufferInfo" get-console-screen-buffer-info)
|
|
sb-alien:boolean
|
|
(console-output sb-win32:handle)
|
|
(info (* (sb-alien:struct console-screen-buffer-info))))
|
|
|
|
(defun get-attributes ()
|
|
(sb-alien:with-alien ((info (sb-alien:struct console-screen-buffer-info)))
|
|
(get-console-screen-buffer-info (output-handle)
|
|
(sb-alien:addr info))
|
|
(sb-alien:slot info 'attributes)))
|
|
|
|
(defun console-color (color)
|
|
(ecase color
|
|
(:red 4)
|
|
(:green 2)))
|
|
|
|
(defun set-color (color)
|
|
(set-console-text-attribute (output-handle) color))
|
|
|
|
(defun %output-colored-text (text color &key bold)
|
|
(declare (ignore bold))
|
|
(let ((current-attributes (get-attributes)))
|
|
(unwind-protect
|
|
(progn (set-color (console-color color))
|
|
(write-string text)
|
|
(finish-output))
|
|
(set-color current-attributes))))
|