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-highlight)
34 (defvar riece-ctlseq-colors
35 '("white" "black" "red" "orange" "yellow" "LightGreen" "DarkOliveGreen"
36 "cyan4" "turquoise" "blue" "black" "black" "black" "black" "black"
37 "DarkBlue" "purple1" "purple2" "purple3" "magenta"))
39 (defvar riece-ctlseq-face-cache nil)
40 (defvar riece-ctlseq-face-cache-size 128)
41 (defvar riece-ctlseq-face-counter 0)
43 (defun riece-ctlseq-compatible-attributes-p (this other)
47 (unless (equal (plist-get other (car pointer)) (nth 1 pointer))
48 (throw 'mismatched nil))
49 (setq pointer (nthcdr 2 pointer)))
52 (defun riece-ctlseq-face-foreground-name (face)
53 "Return the name of FACE's foreground color."
54 (if (fboundp 'face-foreground-name) ;XEmacs
55 (face-foreground-name face)
56 (face-foreground face)))
58 (defun riece-ctlseq-face-background-name (face)
59 "Return the name of FACE's background color."
60 (if (fboundp 'face-background-name) ;XEmacs
61 (face-background-name face)
62 (face-background face)))
64 (defun riece-ctlseq-make-face (attrs)
65 (let* ((face-name (intern (format "riece-ctlseq-face-%d"
66 (prog1 riece-ctlseq-face-counter
67 (setq riece-ctlseq-face-counter
68 (1+ riece-ctlseq-face-counter))))))
69 (face (make-face face-name))
72 (if (plist-get attrs 'bold)
73 (make-face-bold face))
74 (if (plist-get attrs 'underline)
75 (set-face-underline-p face t))
76 (if (setq foreground (plist-get attrs 'foreground))
77 (set-face-foreground face foreground))
78 (if (setq background (plist-get attrs 'background))
79 (set-face-background face background))
80 (when (plist-get attrs 'inverse-video)
81 (setq foreground (or (riece-ctlseq-face-background-name face)
82 (riece-ctlseq-face-background-name 'default))
83 background (or (riece-ctlseq-face-foreground-name face)
84 (riece-ctlseq-face-foreground-name 'default)))
85 (set-face-foreground face foreground)
86 (set-face-background face background))
87 (put face-name 'riece-ctlseq-attributes attrs)
90 (defun riece-ctlseq-face-from-cache (attrs)
93 (let ((pointer riece-ctlseq-face-cache)
98 (setq other (get (car pointer) 'riece-ctlseq-attributes))
99 (when (and (riece-ctlseq-compatible-attributes-p attrs other)
100 (riece-ctlseq-compatible-attributes-p other attrs))
102 (setcdr last-pointer (cdr pointer)))
103 (throw 'found (setcar riece-ctlseq-face-cache (car pointer))))
104 (setq last-pointer pointer
105 pointer (cdr pointer)))
106 (if (>= (length riece-ctlseq-face-cache)
107 riece-ctlseq-face-cache-size)
108 (setq riece-ctlseq-face-cache
109 (butlast riece-ctlseq-face-cache)))
110 (setq riece-ctlseq-face-cache
111 (cons (riece-ctlseq-make-face attrs)
112 riece-ctlseq-face-cache))
113 (car riece-ctlseq-face-cache)))))
115 (defun riece-ctlseq-update-attributes (tag attrs)
117 ((eq (aref tag 0) ?\x2) ;^B
118 (plist-put attrs 'bold (not (plist-get attrs 'bold))))
119 ((eq (aref tag 0) ?\xF)) ;^O
120 ((eq (aref tag 0) ?\x16) ;^V
121 (plist-put attrs 'inverse-video (not (plist-get attrs 'inverse-video))))
122 ((eq (aref tag 0) ?\x1F) ;^_
123 (plist-put attrs 'underline (not (plist-get attrs 'underline))))
124 ((string-match "\x3\\([0-9]+\\)?\\(,[0-9]+\\)?" tag) ;^C<fg>,<bg>
125 (if (match-beginning 1)
126 (setq attrs (plist-put attrs 'foreground
127 (nth (string-to-number (match-string 1 tag))
128 riece-ctlseq-colors))))
129 (if (match-beginning 2)
130 (setq attrs (plist-put attrs 'background
131 (nth (string-to-number
132 (substring (match-string 2 tag) 1))
133 riece-ctlseq-colors))))
136 (defun riece-ctlseq-message-filter (message)
138 (end (length (riece-message-text message)))
141 "[\x2\xF\x16\x1F]\\|\x3\\([0-9]+\\)?\\(,[0-9]+\\)?"
142 (riece-message-text message) start)
143 (put-text-property (match-beginning 0) (match-end 0)
144 'invisible 'riece-ctlseq (riece-message-text message))
146 (put-text-property start (match-beginning 0)
147 'riece-ctlseq-attributes (copy-sequence attrs)
148 (riece-message-text message)))
149 (setq start (match-end 0)
150 attrs (riece-ctlseq-update-attributes
151 (match-string 0 (riece-message-text message)) attrs)))
152 (if (and (< start end) attrs)
153 (put-text-property start end
154 'riece-ctlseq-attributes (copy-sequence attrs)
155 (riece-message-text message))))
158 (defun riece-ctlseq-scan-region (start end)
159 (riece-scan-property-region
160 'riece-ctlseq-attributes
163 (riece-overlay-put (riece-make-overlay start end)
165 (riece-ctlseq-face-from-cache
166 (get-text-property start
167 'riece-ctlseq-attributes))))))
169 (defun riece-ctlseq-requires ()
172 (defun riece-ctlseq-insinuate ()
173 (add-hook 'riece-message-filter-functions 'riece-ctlseq-message-filter)
174 (add-hook 'riece-after-insert-functions 'riece-ctlseq-scan-region))
176 (provide 'riece-ctlseq)
178 ;;; riece-ctlseq.el ends here