From: ueno Date: Tue, 4 May 2004 05:36:31 +0000 (+0000) Subject: * riece-ctlseq.el: New add-on. X-Git-Tag: riece-0_2_2~4 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=d610366b5e4d608dfb5c1320acde49b7e5bdbe26;p=elisp%2Friece.git * riece-ctlseq.el: New add-on. * COMPILE (riece-modules): Add riece-ctlseq. * Makefile.am (EXTRA_DIST): Add riece-ctlseq.el. --- diff --git a/lisp/COMPILE b/lisp/COMPILE index be964cf..246a628 100644 --- a/lisp/COMPILE +++ b/lisp/COMPILE @@ -62,7 +62,8 @@ riece-icon riece-async riece-lsdb - riece-xface)))) + riece-xface + riece-ctlseq)))) (defun riece-compile-modules (modules) (let ((load-path (cons nil load-path))) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index f3c488f..35ef5be 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2004-05-04 Daiki Ueno + + * riece-ctlseq.el: New add-on. + * COMPILE (riece-modules): Add riece-ctlseq. + * Makefile.am (EXTRA_DIST): Add riece-ctlseq.el. + 2004-04-29 OHASHI Akira * riece-log.el (riece-log-get-directory): Use a canonicalized diff --git a/lisp/Makefile.am b/lisp/Makefile.am index 8a7d4b8..e50d78a 100644 --- a/lisp/Makefile.am +++ b/lisp/Makefile.am @@ -10,7 +10,8 @@ EXTRA_DIST = COMPILE ChangeLog ChangeLog.Liece \ riece-ndcc.el riece-rdcc.el riece-log.el riece-mini.el \ riece-doctor.el riece-alias.el riece-layout.el riece-skk-kakutei.el \ riece-guess.el riece-history.el riece-button.el riece-keyword.el \ - riece-menu.el riece-icon.el riece-async.el riece-lsdb.el riece-xface.el + riece-menu.el riece-icon.el riece-async.el riece-lsdb.el \ + riece-xface.el riece-ctlseq.el CLEANFILES = auto-autoloads.el custom-load.el *.elc FLAGS ?= -batch -q -no-site-file diff --git a/lisp/riece-ctlseq.el b/lisp/riece-ctlseq.el new file mode 100644 index 0000000..87729d5 --- /dev/null +++ b/lisp/riece-ctlseq.el @@ -0,0 +1,178 @@ +;;; riece-ctlseq.el --- highlight control sequences in channel buffers +;; Copyright (C) 1998-2004 Daiki Ueno + +;; Author: Daiki Ueno +;; 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, + (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