From: Stas Boukarev Date: Tue, 5 Feb 2013 10:53:06 +0000 (+0400) Subject: Test-suite results colorization. X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=1e1256e90b46cbe903642d7bdc2f183ef19ccf15;p=sbcl.git 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 --- 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 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 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 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 --- 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)