--- /dev/null
+;;; riece-ctlseq.el --- highlight control sequences in channel buffers
+;; Copyright (C) 1998-2004 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Created: 1998-09-28
+;; Keywords: IRC, riece
+
+;; This file is part of Riece.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; To use, add the following line to your ~/.riece/init.el:
+;; (add-to-list 'riece-addons 'riece-ctlseq)
+
+;;; Code:
+
+(require 'riece-highlight)
+
+(defvar riece-ctlseq-colors
+ '("white" "black" "red" "orange" "yellow" "LightGreen" "DarkOliveGreen"
+ "cyan4" "turquoise" "blue" "black" "black" "black" "black" "black"
+ "DarkBlue" "purple1" "purple2" "purple3" "magenta"))
+
+(defvar riece-ctlseq-face-cache nil)
+(defvar riece-ctlseq-face-cache-size 128)
+(defvar riece-ctlseq-face-counter 0)
+
+(defun riece-ctlseq-compatible-attributes-p (this other)
+ (let ((pointer this))
+ (catch 'mismatched
+ (while pointer
+ (unless (equal (plist-get other (car pointer)) (nth 1 pointer))
+ (throw 'mismatched nil))
+ (setq pointer (nthcdr 2 pointer)))
+ t)))
+
+(defun riece-ctlseq-face-foreground-name (face)
+ "Return the name of FACE's foreground color."
+ (if (fboundp 'face-foreground-name) ;XEmacs
+ (face-foreground-name face)
+ (face-foreground face)))
+
+(defun riece-ctlseq-face-background-name (face)
+ "Return the name of FACE's background color."
+ (if (fboundp 'face-background-name) ;XEmacs
+ (face-background-name face)
+ (face-background face)))
+
+(defun riece-ctlseq-make-face (attrs)
+ (let* ((face-name (intern (format "riece-ctlseq-face-%d"
+ (prog1 riece-ctlseq-face-counter
+ (setq riece-ctlseq-face-counter
+ (1+ riece-ctlseq-face-counter))))))
+ (face (make-face face-name))
+ foreground
+ background)
+ (if (plist-get attrs 'bold)
+ (make-face-bold face))
+ (if (plist-get attrs 'underline)
+ (set-face-underline-p face t))
+ (if (setq foreground (plist-get attrs 'foreground))
+ (set-face-foreground face foreground))
+ (if (setq background (plist-get attrs 'background))
+ (set-face-background face background))
+ (when (plist-get attrs 'inverse-video)
+ (setq foreground (or (riece-ctlseq-face-background-name face)
+ (riece-ctlseq-face-background-name 'default))
+ background (or (riece-ctlseq-face-foreground-name face)
+ (riece-ctlseq-face-foreground-name 'default)))
+ (set-face-foreground face foreground)
+ (set-face-background face background))
+ (put face-name 'riece-ctlseq-attributes attrs)
+ face-name))
+
+(defun riece-ctlseq-face-from-cache (attrs)
+ (if (null attrs)
+ 'default
+ (let ((pointer riece-ctlseq-face-cache)
+ last-pointer
+ other)
+ (catch 'found
+ (while pointer
+ (setq other (get (car pointer) 'riece-ctlseq-attributes))
+ (when (and (riece-ctlseq-compatible-attributes-p attrs other)
+ (riece-ctlseq-compatible-attributes-p other attrs))
+ (if last-pointer
+ (setcdr last-pointer (cdr pointer)))
+ (throw 'found (setcar riece-ctlseq-face-cache (car pointer))))
+ (setq last-pointer pointer
+ pointer (cdr pointer)))
+ (if (>= (length riece-ctlseq-face-cache)
+ riece-ctlseq-face-cache-size)
+ (setq riece-ctlseq-face-cache
+ (butlast riece-ctlseq-face-cache)))
+ (setq riece-ctlseq-face-cache
+ (cons (riece-ctlseq-make-face attrs)
+ riece-ctlseq-face-cache))
+ (car riece-ctlseq-face-cache)))))
+
+(defun riece-ctlseq-update-attributes (tag attrs)
+ (cond
+ ((eq (aref tag 0) ?\x2) ;^B
+ (plist-put attrs 'bold (not (plist-get attrs 'bold))))
+ ((eq (aref tag 0) ?\xF)) ;^O
+ ((eq (aref tag 0) ?\x16) ;^V
+ (plist-put attrs 'inverse-video (not (plist-get attrs 'inverse-video))))
+ ((eq (aref tag 0) ?\x1F) ;^_
+ (plist-put attrs 'underline (not (plist-get attrs 'underline))))
+ ((string-match "\x3\\([0-9]+\\)?\\(,[0-9]+\\)?" tag) ;^C<fg>,<bg>
+ (if (match-beginning 1)
+ (setq attrs (plist-put attrs 'foreground
+ (nth (string-to-number (match-string 1 tag))
+ riece-ctlseq-colors))))
+ (if (match-beginning 2)
+ (setq attrs (plist-put attrs 'background
+ (nth (string-to-number
+ (substring (match-string 2 tag) 1))
+ riece-ctlseq-colors))))
+ attrs)))
+
+(defun riece-ctlseq-message-filter (message)
+ (let ((start 0)
+ (end (length (riece-message-text message)))
+ attrs)
+ (while (string-match
+ "[\x2\xF\x16\x1F]\\|\x3\\([0-9]+\\)?\\(,[0-9]+\\)?"
+ (riece-message-text message) start)
+ (put-text-property (match-beginning 0) (match-end 0)
+ 'invisible 'riece-ctlseq (riece-message-text message))
+ (if attrs
+ (put-text-property start (match-beginning 0)
+ 'riece-ctlseq-attributes (copy-sequence attrs)
+ (riece-message-text message)))
+ (setq start (match-end 0)
+ attrs (riece-ctlseq-update-attributes
+ (match-string 0 (riece-message-text message)) attrs)))
+ (if (and (< start end) attrs)
+ (put-text-property start end
+ 'riece-ctlseq-attributes (copy-sequence attrs)
+ (riece-message-text message))))
+ message)
+
+(defun riece-ctlseq-scan-region (start end)
+ (riece-scan-property-region
+ 'riece-ctlseq-attributes
+ start end
+ (lambda (start end)
+ (riece-overlay-put (riece-make-overlay start end)
+ 'face
+ (riece-ctlseq-face-from-cache
+ (get-text-property start
+ 'riece-ctlseq-attributes))))))
+
+(defun riece-ctlseq-requires ()
+ '(riece-highlight))
+
+(defun riece-ctlseq-insinuate ()
+ (add-hook 'riece-message-filter-functions 'riece-ctlseq-message-filter)
+ (add-hook 'riece-after-insert-functions 'riece-ctlseq-scan-region))
+
+(provide 'riece-ctlseq)
+
+;;; riece-ctlseq.el ends here
projects / elisp / riece.git / commitdiff