tests/colorize.lisp

   1 (defvar *no-color*
   2   (member "--no-color" *posix-argv* :test #'equal))
   3
   4 (defvar *color-error* nil)
   5
   6 (unless *no-color*
   7   (let ((file #-win32 "colorize-control-codes.lisp"
   8               #+win32 "colorize-windows-console.lisp"))
   9     (handler-case (load file)
  10       (error (c)
  11         (setf *color-error*
  12               (format nil "Error while loading ~a:~% ~a"
  13                       (enough-namestring file)
  14                       c))))))
  15
  16 (defun is-tty ()
  17   (let* ((stream (sb-impl::stream-output-stream  *standard-output*))
  18          (fd (and (sb-sys:fd-stream-p stream)
  19                   (sb-sys:fd-stream-fd stream))))
  20     (when (integerp fd)
  21       (plusp (sb-unix:unix-isatty fd)))))
  22
  23 (defun present-coloring-error (error)
  24   (format t "~a~%" error)
  25   (format t "Switching off colored output,~%~
  26                     it can be turned off by passing --no-color~%~%")
  27   (setf *no-color* t))
  28
  29 (defun output-colored-text (kind text
  30                             &key (align 20))
  31   (cond ((or (not (is-tty))
  32              *no-color*)
  33          (write-string text))
  34         (*color-error*
  35          (present-coloring-error *color-error*)
  36          (write-string text))
  37         (t
  38          (handler-case
  39              (case kind
  40                ((:unexpected-failure
  41                  :leftover-thread
  42                  :unhandled-error
  43                  :invalid-exit-status)
  44                 (%output-colored-text text :red :bold t))
  45                ((:unexpected-success)
  46                 (%output-colored-text text :green))
  47                (t
  48                 (write-string text)))
  49            (error (c)
  50              (present-coloring-error
  51               (format nil "Error while printing colored text:~% ~a"
  52                       c))
  53              (write-string text)))))
  54   (write-string (make-string (max 0 (- align (length text)))
  55                              :initial-element #\Space)))