tests/colorize-windows-console.lisp

   1
   2 (defun output-handle ()
   3   (sb-win32::get-std-handle-or-null
   4    sb-win32::+std-output-handle+))
   5
   6 (sb-alien:define-alien-type nil
   7     (sb-alien:struct console-screen-buffer-info
   8             (size sb-alien:int)
   9             (cursor-position sb-alien:int)
  10             (attributes sb-alien:int)
  11             (window sb-win32:dword)
  12             (maximum-window-size sb-alien:int)))
  13
  14 (sb-alien:define-alien-routine
  15     ("SetConsoleTextAttribute" set-console-text-attribute)
  16   sb-alien:boolean
  17   (console sb-win32:handle)
  18   (attributes sb-alien:int))
  19
  20 (sb-alien:define-alien-routine
  21     ("GetConsoleScreenBufferInfo" get-console-screen-buffer-info)
  22   sb-alien:boolean
  23   (console-output sb-win32:handle)
  24   (info (* (sb-alien:struct console-screen-buffer-info))))
  25
  26 (defun get-attributes ()
  27   (sb-alien:with-alien ((info (sb-alien:struct console-screen-buffer-info)))
  28     (get-console-screen-buffer-info (output-handle)
  29                                     (sb-alien:addr info))
  30     (sb-alien:slot info 'attributes)))
  31
  32 (defun console-color (color)
  33   (ecase color
  34     (:red 4)
  35     (:green 2)))
  36
  37 (defun set-color (color)
  38   (set-console-text-attribute (output-handle) color))
  39
  40 (defun %output-colored-text (text color &key bold)
  41   (declare (ignore bold))
  42   (let ((current-attributes (get-attributes)))
  43     (unwind-protect
  44          (progn (set-color (console-color color))
  45                 (write-string text)
  46                 (finish-output))
  47       (set-color current-attributes))))