1 ;;; riece-ctlseq.el --- highlight control sequences in channel buffers
2 ;; Copyright (C) 1998-2004 Daiki Ueno
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
6 ;; Keywords: IRC, riece
8 ;; This file is part of Riece.
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
27 ;; To use, add the following line to your ~/.riece/init.el:
28 ;; (add-to-list 'riece-addons 'riece-ctlseq)
32 (require 'riece-options)
34 (defgroup 'riece-ctlseq nil
35 "Highlight control sequences in IRC buffer."
38 (defcustom riece-ctlseq-colors
39 '("white" "black" "red" "orange" "yellow" "LightGreen" "DarkOliveGreen"
40 "cyan4" "turquoise" "blue" "black" "black" "black" "black" "black"
41 "DarkBlue" "purple1" "purple2" "purple3" "magenta")
42 "List of colors can be used with ^C<fg>,<bg>."
44 :type '(repeat (string :tag "Color")))
46 (defcustom riece-ctlseq-hide-controls t
47 "If non-nil, control characters are hidden."
51 (defcustom riece-ctlseq-face-cache-size 128
52 "Maximum length of the internal face cache."
56 (defvar riece-ctlseq-face-cache nil)
57 (defvar riece-ctlseq-face-counter 0)
59 (defun riece-ctlseq-compatible-attributes-p (this other)
63 (unless (equal (plist-get other (car pointer)) (nth 1 pointer))
64 (throw 'mismatched nil))
65 (setq pointer (nthcdr 2 pointer)))
68 (defun riece-ctlseq-face-foreground-name (face)
69 "Return the name of FACE's foreground color."
70 (if (fboundp 'face-foreground-name) ;XEmacs
71 (face-foreground-name face)
72 (face-foreground face)))
74 (defun riece-ctlseq-face-background-name (face)
75 "Return the name of FACE's background color."
76 (if (fboundp 'face-background-name) ;XEmacs
77 (face-background-name face)
78 (face-background face)))
80 (defun riece-ctlseq-make-face (attrs)
81 (let* ((face-name (intern (format "riece-ctlseq-face-%d"
82 (prog1 riece-ctlseq-face-counter
83 (setq riece-ctlseq-face-counter
84 (1+ riece-ctlseq-face-counter))))))
85 (face (make-face face-name))
88 (if (plist-get attrs 'bold)
89 (make-face-bold face))
90 (if (plist-get attrs 'underline)
91 (set-face-underline-p face t))
92 (if (setq foreground (plist-get attrs 'foreground))
93 (set-face-foreground face foreground))
94 (if (setq background (plist-get attrs 'background))
95 (set-face-background face background))
96 (when (plist-get attrs 'inverse-video)
97 (setq foreground (or (riece-ctlseq-face-background-name face)
98 (riece-ctlseq-face-background-name 'default))
99 background (or (riece-ctlseq-face-foreground-name face)
100 (riece-ctlseq-face-foreground-name 'default)))
101 (set-face-foreground face foreground)
102 (set-face-background face background))
103 (put face-name 'riece-ctlseq-attributes attrs)
106 (defun riece-ctlseq-face-from-cache (attrs)
109 (let ((pointer riece-ctlseq-face-cache)
114 (setq other (get (car pointer) 'riece-ctlseq-attributes))
115 (when (and (riece-ctlseq-compatible-attributes-p attrs other)
116 (riece-ctlseq-compatible-attributes-p other attrs))
118 (setcdr last-pointer (cdr pointer)))
119 (throw 'found (setcar riece-ctlseq-face-cache (car pointer))))
120 (setq last-pointer pointer
121 pointer (cdr pointer)))
122 (if (>= (length riece-ctlseq-face-cache)
123 riece-ctlseq-face-cache-size)
124 (setq riece-ctlseq-face-cache
125 (butlast riece-ctlseq-face-cache)))
126 (setq riece-ctlseq-face-cache
127 (cons (riece-ctlseq-make-face attrs)
128 riece-ctlseq-face-cache))
129 (car riece-ctlseq-face-cache)))))
131 (defun riece-ctlseq-update-attributes (tag attrs)
133 ((eq (aref tag 0) ?\x2) ;^B
134 (plist-put attrs 'bold (not (plist-get attrs 'bold))))
135 ((eq (aref tag 0) ?\xF)) ;^O
136 ((eq (aref tag 0) ?\x16) ;^V
137 (plist-put attrs 'inverse-video (not (plist-get attrs 'inverse-video))))
138 ((eq (aref tag 0) ?\x1F) ;^_
139 (plist-put attrs 'underline (not (plist-get attrs 'underline))))
140 ((string-match "\x3\\([0-9]+\\)?\\(,[0-9]+\\)?" tag) ;^C<fg>,<bg>
141 (if (match-beginning 1)
142 (setq attrs (plist-put attrs 'foreground
143 (nth (string-to-number (match-string 1 tag))
144 riece-ctlseq-colors))))
145 (if (match-beginning 2)
146 (setq attrs (plist-put attrs 'background
147 (nth (string-to-number
148 (substring (match-string 2 tag) 1))
149 riece-ctlseq-colors))))
152 (defun riece-ctlseq-message-filter (message)
154 (end (length (riece-message-text message)))
157 "[\x2\xF\x16\x1F]\\|\x3\\([0-9]+\\)?\\(,[0-9]+\\)?"
158 (riece-message-text message) start)
159 (if riece-ctlseq-hide-controls
160 (put-text-property (match-beginning 0) (match-end 0)
161 'invisible 'riece-ctlseq
162 (riece-message-text message)))
164 (put-text-property start (match-beginning 0)
165 'riece-ctlseq-attributes (copy-sequence attrs)
166 (riece-message-text message)))
167 (setq start (match-end 0)
168 attrs (riece-ctlseq-update-attributes
169 (match-string 0 (riece-message-text message)) attrs)))
170 (if (and (< start end) attrs)
171 (put-text-property start end
172 'riece-ctlseq-attributes (copy-sequence attrs)
173 (riece-message-text message))))
176 (defun riece-ctlseq-scan-region (start end)
177 (riece-scan-property-region
178 'riece-ctlseq-attributes
181 (riece-overlay-put (riece-make-overlay start end)
183 (riece-ctlseq-face-from-cache
184 (get-text-property start
185 'riece-ctlseq-attributes))))))
187 (defun riece-ctlseq-insinuate ()
188 (add-hook 'riece-message-filter-functions 'riece-ctlseq-message-filter)
189 (add-hook 'riece-after-insert-functions 'riece-ctlseq-scan-region))
191 (provide 'riece-ctlseq)
193 ;;; riece-ctlseq.el ends here