tests/colorize.lisp

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