1 ;;; riece-ctlseq.el --- mark up control sequences in IRC buffers -*- lexical-binding: t -*-
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., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
27 ;; NOTE: This is an add-on module for Riece.
31 (require 'riece-message)
34 (defgroup riece-ctlseq nil
35 "Mark up control sequences in IRC buffer."
39 (defcustom riece-ctlseq-colors
40 '("white" "black" "red" "orange" "yellow" "LightGreen" "DarkOliveGreen"
41 "cyan4" "turquoise" "blue" "black" "black" "black" "black" "black"
42 "DarkBlue" "purple1" "purple2" "purple3" "magenta")
43 "List of colors can be used with ^C<fg>,<bg>.
45 To set up colors compatible with X-Chat and mIRC, do:
46 \(setq riece-ctlseq-colors '(\"#cecece\" \"black\" \"#0000cc\" \"#00cc00\"
47 \"#dd0000\" \"#aa0000\" \"#bb00bb\" \"#ffaa00\"
48 \"#eedd22\" \"#33de55\" \"#00cccc\" \"#33eeff\"
49 \"#0000ff\" \"#ee22ee\" \"#777777\" \"#999999\"))
52 :type '(repeat (string :tag "Color")))
54 (defcustom riece-ctlseq-hide-controls t
55 "If non-nil, control characters are hidden."
59 (defcustom riece-ctlseq-face-cache-size 128
60 "Maximum length of the internal face cache."
64 (defvar riece-ctlseq-face-cache nil)
65 (defvar riece-ctlseq-face-counter 0)
67 (defconst riece-ctlseq-description
68 "Mark up control sequences in IRC buffers.")
70 (defconst riece-ctlseq-regexp
71 "[\x2\xF\x16\x1F]\\|\x3\\([0-9][0-9]?\\)\\(,[0-9][0-9]?\\)?")
73 (defun riece-ctlseq-compatible-attributes-p (this other)
77 (unless (equal (plist-get other (car pointer)) (nth 1 pointer))
78 (throw 'mismatched nil))
79 (setq pointer (nthcdr 2 pointer)))
82 (defun riece-ctlseq-face-foreground-name (face)
83 "Return the name of FACE's foreground color."
84 (if (fboundp 'face-foreground-name) ;XEmacs
85 (face-foreground-name face)
86 (face-foreground face)))
88 (defun riece-ctlseq-face-background-name (face)
89 "Return the name of FACE's background color."
90 (if (fboundp 'face-background-name) ;XEmacs
91 (face-background-name face)
92 (face-background face)))
94 (defun riece-ctlseq-make-face (attrs)
95 (let* ((face-name (intern (format "riece-ctlseq-face-%d"
96 (prog1 riece-ctlseq-face-counter
97 (setq riece-ctlseq-face-counter
98 (1+ riece-ctlseq-face-counter))))))
99 (face (make-face face-name))
102 (if (plist-get attrs 'bold)
103 (make-face-bold face))
104 (if (plist-get attrs 'underline)
105 (set-face-underline-p face t))
106 (if (setq foreground (plist-get attrs 'foreground))
107 (set-face-foreground face foreground))
108 (if (setq background (plist-get attrs 'background))
109 (set-face-background face background))
110 (when (plist-get attrs 'inverse-video)
111 (setq foreground (or (riece-ctlseq-face-background-name face)
112 (riece-ctlseq-face-background-name 'default))
113 background (or (riece-ctlseq-face-foreground-name face)
114 (riece-ctlseq-face-foreground-name 'default)))
115 (set-face-foreground face foreground)
116 (set-face-background face background))
117 (put face-name 'riece-ctlseq-attributes attrs)
120 (defun riece-ctlseq-face-from-cache (attrs)
123 (let ((pointer riece-ctlseq-face-cache)
128 (setq other (get (car pointer) 'riece-ctlseq-attributes))
129 (when (and (riece-ctlseq-compatible-attributes-p attrs other)
130 (riece-ctlseq-compatible-attributes-p other attrs))
132 (setcdr last-pointer (cdr pointer)))
133 (throw 'found (setcar riece-ctlseq-face-cache (car pointer))))
134 (setq last-pointer pointer
135 pointer (cdr pointer)))
136 (if (>= (length riece-ctlseq-face-cache)
137 riece-ctlseq-face-cache-size)
138 (setq riece-ctlseq-face-cache
139 (butlast riece-ctlseq-face-cache)))
140 (setq riece-ctlseq-face-cache
141 (cons (riece-ctlseq-make-face attrs)
142 riece-ctlseq-face-cache))
143 (car riece-ctlseq-face-cache)))))
145 (defun riece-ctlseq-update-attribute (tag attrs)
146 (let ((attrs (copy-sequence attrs)))
148 ((eq (aref tag 0) ?\x2) ;^B
149 (setq attrs (plist-put attrs 'bold (not (plist-get attrs 'bold)))))
150 ((eq (aref tag 0) ?\xF) ;^O
152 ((eq (aref tag 0) ?\x16) ;^V
153 (setq attrs (plist-put attrs 'inverse-video
154 (not (plist-get attrs 'inverse-video)))))
155 ((eq (aref tag 0) ?\x1F) ;^_
156 (setq attrs (plist-put attrs 'underline
157 (not (plist-get attrs 'underline)))))
158 ((eq (aref tag 0) ?\x3) ;^C<fg>[,<bg>]
159 (setq attrs (plist-put attrs 'foreground
160 (nth (string-to-number (substring tag 1))
161 riece-ctlseq-colors)))
162 (if (string-match "," tag)
163 (setq attrs (plist-put attrs 'background
164 (nth (string-to-number
165 (substring tag (match-end 0)))
166 riece-ctlseq-colors))))))
169 (defun riece-ctlseq-update-attributes (tags attrs)
171 (while (string-match riece-ctlseq-regexp tags start)
172 (setq start (match-end 0)
173 attrs (riece-ctlseq-update-attribute (match-string 0 tags) attrs)))
176 (defun riece-ctlseq-put-attributes (string start end attrs)
177 (when (and (> end start) attrs)
178 (put-text-property start end
179 'riece-ctlseq-attributes (copy-sequence attrs)
181 (put-text-property start end
183 (riece-ctlseq-face-from-cache attrs)
186 (defun riece-ctlseq-message-filter (message)
187 (if (get 'riece-ctlseq 'riece-addon-enabled)
189 (end (length (riece-message-text message)))
190 tags-start tags-end attrs)
191 (while (string-match (concat "\\(" riece-ctlseq-regexp "\\)+")
192 (riece-message-text message) start)
193 (if riece-ctlseq-hide-controls
194 (put-text-property (match-beginning 0) (match-end 0)
195 'invisible 'riece-ctlseq
196 (riece-message-text message)))
197 (setq tags-start (match-beginning 0)
198 tags-end (match-end 0))
199 (riece-ctlseq-put-attributes (riece-message-text message)
202 (setq attrs (riece-ctlseq-update-attributes
203 (substring (riece-message-text message)
207 (riece-ctlseq-put-attributes (riece-message-text message)
212 (defun riece-ctlseq-requires ()
215 (defun riece-ctlseq-insinuate ()
216 (add-hook 'riece-message-filter-functions 'riece-ctlseq-message-filter))
218 (defun riece-ctlseq-uninstall ()
219 (remove-hook 'riece-message-filter-functions 'riece-ctlseq-message-filter))
221 (provide 'riece-ctlseq)
223 ;;; riece-ctlseq.el ends here