87729d5c742cd2ff558c0776685ccfc9639d9e87
[riece] / lisp / riece-ctlseq.el
1 ;;; riece-ctlseq.el --- highlight control sequences in channel buffers
2 ;; Copyright (C) 1998-2004 Daiki Ueno
3
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
5 ;; Created: 1998-09-28
6 ;; Keywords: IRC, riece
7
8 ;; This file is part of Riece.
9
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)
13 ;; any later version.
14
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.
19
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.
24
25 ;;; Commentary:
26
27 ;; To use, add the following line to your ~/.riece/init.el:
28 ;; (add-to-list 'riece-addons 'riece-ctlseq)
29
30 ;;; Code:
31
32 (require 'riece-highlight)
33
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"))
38
39 (defvar riece-ctlseq-face-cache nil)
40 (defvar riece-ctlseq-face-cache-size 128)
41 (defvar riece-ctlseq-face-counter 0)
42
43 (defun riece-ctlseq-compatible-attributes-p (this other)
44   (let ((pointer this))
45     (catch 'mismatched
46       (while pointer
47         (unless (equal (plist-get other (car pointer)) (nth 1 pointer))
48           (throw 'mismatched nil))
49         (setq pointer (nthcdr 2 pointer)))
50       t)))
51
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)))
57
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)))
63
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))
70          foreground
71          background)
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)
88     face-name))
89
90 (defun riece-ctlseq-face-from-cache (attrs)
91   (if (null attrs)
92       'default
93     (let ((pointer riece-ctlseq-face-cache)
94           last-pointer
95           other)
96       (catch 'found
97         (while pointer
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))
101             (if last-pointer
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)))))
114
115 (defun riece-ctlseq-update-attributes (tag attrs)
116   (cond
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))))
134     attrs)))
135
136 (defun riece-ctlseq-message-filter (message)
137   (let ((start 0)
138         (end (length (riece-message-text message)))
139         attrs)
140     (while (string-match
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))
145       (if attrs
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))))
156   message)
157
158 (defun riece-ctlseq-scan-region (start end)
159   (riece-scan-property-region
160    'riece-ctlseq-attributes
161    start end
162    (lambda (start end)
163      (riece-overlay-put (riece-make-overlay start end)
164                         'face
165                         (riece-ctlseq-face-from-cache
166                          (get-text-property start
167                                             'riece-ctlseq-attributes))))))
168
169 (defun riece-ctlseq-requires ()
170   '(riece-highlight))
171                             
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))
175
176 (provide 'riece-ctlseq)
177
178 ;;; riece-ctlseq.el ends here