Test-suite results colorization.

[sbcl.git] / tests / colorize.lisp

diff --git a/tests/colorize.lisp b/tests/colorize.lisp
new file mode 100644 (file)
index 0000000..c12a1a4
--- /dev/null
+++ b/tests/colorize.lisp
@@ -0,0 +1,55 @@
+(defvar *no-color*
+  (member "--no-color" *posix-argv* :test #'equal))
+
+(defvar *color-error* nil)
+
+(unless *no-color*
+  (let ((file #-win32 "colorize-control-codes.lisp"
+              #+win32 "colorize-windows-console.lisp"))
+    (handler-case (load file)
+      (error (c)
+        (setf *color-error*
+              (format nil "Error while loading ~a:~% ~a"
+                      (enough-namestring file)
+                      c))))))
+
+(defun is-tty ()
+  (let* ((stream (sb-impl::stream-output-stream  *standard-output*))
+         (fd (and (sb-sys:fd-stream-p stream)
+                  (sb-sys:fd-stream-fd stream))))
+    (when (integerp fd)
+      (plusp (sb-unix:unix-isatty fd)))))
+
+(defun present-coloring-error (error)
+  (format t "~a~%" error)
+  (format t "Switching off colored output,~%~
+                    it can be turned off by passing --no-color~%~%")
+  (setf *no-color* t))
+
+(defun output-colored-text (kind text
+                            &key (align 20))
+  (cond ((or (not (is-tty))
+             *no-color*)
+         (write-string text))
+        (*color-error*
+         (present-coloring-error *color-error*)
+         (write-string text))
+        (t
+         (handler-case
+             (case kind
+               ((:unexpected-failure
+                 :leftover-thread
+                 :unhandled-error
+                 :invalid-exit-status)
+                (%output-colored-text text :red :bold t))
+               ((:unexpected-success)
+                (%output-colored-text text :green))
+               (t
+                (write-string text)))
+           (error (c)
+             (present-coloring-error
+              (format nil "Error while printing colored text:~% ~a"
+                      c))
+             (write-string text)))))
+  (write-string (make-string (max 0 (- align (length text)))
+                             :initial-element #\Space)))