blob: d6f64afc6d64aa128919d85dea9afc27aeef29c3 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
(defpackage ansi-color
(:use :cl :cl-user :moxie :bjc-utils))
(in-package :ansi-color)
(defvar *black-color* '(0 0 0))
(defvar *red-color* '(200 0 0))
(defvar *green-color* '(0 200 0))
(defvar *yellow-color* '(200 200 0))
(defvar *blue-color* '(0 0 200))
(defvar *purple-color* '(200 0 200))
(defvar *cyan-color* '(0 200 200))
(defvar *white-color* '(200 200 200))
(defun active-attributes (&optional (world *world*))
(world-var 'active-attrs world))
(defsetf active-attributes (&optional (world '*world*)) (values)
`(setf (world-var 'active-attrs ,world) ,values))
(defun add-attribute (attribute)
(remove-attribute (car attribute))
(setf (active-attributes)
(cons attribute (active-attributes))))
(defun attribute-value (attribute)
(cdr (assoc attribute (active-attributes))))
(defun remove-attribute (attribute)
(setf (active-attributes)
(remove attribute (active-attributes) :key #'car)))
(defun set-attribute-for-code (code)
(case code
(0 (when (active-attributes)
(setf (active-attributes) nil)))
(1 (add-attribute '(:bold 1)))
(3 (add-attribute '(:italic 0.25)))
(4 (add-attribute '(:underline 1)))
(7 (add-attribute '(:inverse 1)))
(9 (add-attribute '(:strikethrough 1)))
(22 (remove-attribute :bold))
(23 (remove-attribute :italic))
(24 (remove-attribute :underline))
(27 (remove-attribute :inverse))
(29 (remove-attribute :strikethrough))
(30 (add-attribute (cons :color *black-color*)))
(31 (add-attribute (cons :color *red-color*)))
(32 (add-attribute (cons :color *green-color*)))
(33 (add-attribute (cons :color *yellow-color*)))
(34 (add-attribute (cons :color *blue-color*)))
(35 (add-attribute (cons :color *purple-color*)))
(36 (add-attribute (cons :color *cyan-color*)))
(37 (add-attribute (cons :color *white-color*)))
(39 (remove-attribute :color))
(40 (add-attribute (cons :background-color *black-color*)))
(41 (add-attribute (cons :background-color *red-color*)))
(42 (add-attribute (cons :background-color *green-color*)))
(43 (add-attribute (cons :background-color *yellow-color*)))
(44 (add-attribute (cons :background-color *blue-color*)))
(45 (add-attribute (cons :background-color *purple-color*)))
(46 (add-attribute (cons :background-color *cyan-color*)))
(47 (add-attribute (cons :background-color *white-color*)))
(49 (remove-attribute :background-color))))
(defun end-of-ansi-position (string start)
"Returns the position in STRING after START where an ANSI escape sequence ends."
(position-if (lambda (c)
(or (and (char< c #\z) (char> c #\a))
(and (char< c #\Z) (char> c #\A))))
string :start start))
(defun colorize-ansi-string (string)
(declare (ignore keywords))
(let* (*print-pretty*
(string (concatenate 'string
(aif (world-var 'cached-escape)
(progn
(setf (world-var 'cached-escape) nil)
it)
"")
(if (stringp string) string (car string))))
(scanlen (length string))
(attr-index 0)
(attributes nil)
(skipped-chars 0)
(result (with-output-to-string (stripped-string)
(let ((final-scan (do* ((i 0 (1+ i)))
((>= i scanlen) i)
(when (eql (elt string i) #\Escape)
(aif (end-of-ansi-position string i)
(progn
;; When we have a code, we should dump the last
;; set of attributes.
(princ (subseq string attr-index i) stripped-string)
(awhen (active-attributes)
(push (cons (make-range (- attr-index skipped-chars)
(- i attr-index))
(active-attributes)) attributes))
;; Grab the code sequence, break it up, and set the
;; attributes for it.
(let ((code-str (subseq string (+ i 2) it)))
(flet ((code-in-bounds (start end)
(let ((start (or start 0))
(end (or end (length code-str))))
(set-attribute-for-code (or (and (= start end) 0)
(parse-integer (subseq code-str start end)
:junk-allowed t))))))
;; Coalesce attributes split up by semicolons.
(do* ((last-pos 0 (1+ semi-pos))
(semi-pos (position #\; code-str)
(position #\; code-str :start last-pos))
(code (code-in-bounds last-pos semi-pos)
(code-in-bounds last-pos semi-pos)))
((null semi-pos)))))
(setf skipped-chars (+ skipped-chars (- (1+ it) i)))
(setf i it)
(setf attr-index (1+ i)))
;; We have an escape, but can't parse it.
;; save it in a buffer for later use.
(progn
(setf (world-var 'cached-escape) (subseq string i scanlen))
(setf scanlen i)))))))
;; Append final attributes and string.
(when (<= attr-index scanlen)
(princ (subseq string attr-index scanlen) stripped-string)
(push (cons (make-range (- attr-index skipped-chars) (- scanlen attr-index))
(active-attributes)) attributes))))))
(if attributes
(apply #'make-attributed-string result attributes)
result)))
(defun test-output (&rest vars)
(with-output-to-string (s)
(dolist (v vars)
(format t "first char: ~S, var ~S~%" (elt v 0) v)
(princ v s))))
(defun printer-test ()
(test-output "string-1" (format nil "string-2~%")))
(defun make-ansi-sequence ()
(format nil "~C[~A;~Am~A ~C[~A;~A;~AmAnd another" #\Escape 0 31 "A sequence" #\Escape 1 22 37))
(add-hook 'colorize-ansi-string :output-from-server-hook)
|
