Test-suite results colorization.

Failures in red, unexpected success in green. Works on Windows and on
terminals with ANSI escape code support.
Can be disabled with --no-color.

diff --git a/NEWS b/NEWS
index 057fefa..8985a10 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -24,6 +24,9 @@ changes relative to sbcl-1.1.4:
     ** SB-DEBUG:*SHOW-ENTRY-POINT-DETAILS** has been deprecated, as the same
        information is available in less intrusive form as frame annotations.
   * enhancement: SB-POSIX now provides MAP-ANON.
+  * enhancement: test-suite results are colorized, failures in red, unexpected
+    success in green. Works on Windows and on terminals with ANSI escape code
+    support. Can be disabled with --no-color.
   * bug fix: no more unused variable style warnings from RESTART-CASE
     macroexpansion (lp#1113859)
   * bug fix: no more unused variable style warnings when loading

diff --git a/tests/colorize-control-codes.lisp b/tests/colorize-control-codes.lisp
new file mode 100644 (file)
index 0000000..8bd1592
--- /dev/null
+++ b/tests/colorize-control-codes.lisp
@@ -0,0 +1,11 @@
+(defun ascii-color (color)
+  (ecase color
+    (:red 31)
+    (:green 32)))
+
+(defun %output-colored-text (text color &key bold)
+  (format t "~c[~a~:[~;;1~]m~a~c[0m"
+          #\Esc
+          (ascii-color color)
+          bold
+          text #\Esc))

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))))

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)))

diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp
index 1020dad..8a7db46 100644 (file)
--- a/tests/run-tests.lisp
+++ b/tests/run-tests.lisp
@@ -14,6 +14,8 @@
 
 (in-package run-tests)
 
+(load "colorize.lisp")
+
 (defvar *all-failures* nil)
 (defvar *break-on-error* nil)
 (defvar *report-skipped-tests* nil)
@@ -28,6 +30,7 @@
            (setf test-util:*break-on-expected-failure* t))
           ((string= arg "--report-skipped-tests")
            (setf *report-skipped-tests* t))
+          ((string= arg "--no-color"))
           (t
            (push (truename (parse-namestring arg)) *accept-files*))))
   (pure-runner (pure-load-files) #'load-test)
@@ -49,12 +52,14 @@
            (format t "Status:~%")
            (dolist (fail (reverse *all-failures*))
              (cond ((eq (car fail) :unhandled-error)
-                    (format t " ~20a ~a~%"
-                            "Unhandled error"
+                    (output-colored-text (car fail)
+                                          " Unhandled Error")
+                    (format t " ~a~%"
                             (enough-namestring (second fail))))
                    ((eq (car fail) :invalid-exit-status)
-                    (format t " ~20a ~a~%"
-                            "Invalid exit status:"
+                    (output-colored-text (car fail)
+                                          " Invalid exit status:")
+                    (format t " ~a~%"
                             (enough-namestring (second fail))))
                    ((eq (car fail) :skipped-disabled)
                     (when *report-skipped-tests*
@@ -64,14 +69,16 @@
                               (third fail)))
                     (incf skipcount))
                    (t
-                    (format t " ~20a ~a / ~a~%"
-                            (ecase (first fail)
-                              (:expected-failure "Expected failure:")
-                              (:unexpected-failure "Failure:")
-                              (:leftover-thread "Leftover thread (broken):")
-                              (:unexpected-success "Unexpected success:")
-                              (:skipped-broken "Skipped (broken):")
-                              (:skipped-disabled "Skipped (irrelevant):"))
+                    (output-colored-text
+                     (first fail)
+                     (ecase (first fail)
+                       (:expected-failure " Expected failure:")
+                       (:unexpected-failure " Failure:")
+                       (:leftover-thread " Leftover thread (broken):")
+                       (:unexpected-success " Unexpected success:")
+                       (:skipped-broken " Skipped (broken):")
+                       (:skipped-disabled " Skipped (irrelevant):")))
+                    (format t " ~a / ~a~%"
                             (enough-namestring (second fail))
                             (third fail)))))
            (when (> skipcount 0)