Test-suite results colorization.

[sbcl.git] / tests / colorize-windows-console.lisp

diff --git a/tests/colorize-windows-console.lisp b/tests/colorize-windows-console.lisp
new file mode 100644 (file)
index 0000000..9b153e4
--- /dev/null
+++ b/tests/colorize-windows-console.lisp
@@ -0,0 +1,47 @@
+
+(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))))