cgit.sxemacs.org Git - riece/blob - 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-message)
  33 (require 'riece-misc)
  34
  35 (defgroup riece-ctlseq nil
  36   "Highlight control sequences in IRC buffer."
  37   :group 'riece)
  38
  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>."
  44   :group 'riece-ctlseq
  45   :type '(repeat (string :tag "Color")))
  46
  47 (defcustom riece-ctlseq-hide-controls t
  48   "If non-nil, control characters are hidden."
  49   :group 'riece-ctlseq
  50   :type 'boolean)
  51
  52 (defcustom riece-ctlseq-face-cache-size 128
  53   "Maximum length of the internal face cache."
  54   :group 'riece-ctlseq
  55   :type 'integer)
  56
  57 (defvar riece-ctlseq-face-cache nil)
  58 (defvar riece-ctlseq-face-counter 0)
  59
  60 (defvar riece-ctlseq-enabled nil)
  61
  62 (defvar riece-ctlseq-description
  63   "Highlight control sequences in IRC buffers")
  64
  65 (defun riece-ctlseq-compatible-attributes-p (this other)
  66   (let ((pointer this))
  67     (catch 'mismatched
  68       (while pointer
  69         (unless (equal (plist-get other (car pointer)) (nth 1 pointer))
  70           (throw 'mismatched nil))
  71         (setq pointer (nthcdr 2 pointer)))
  72       t)))
  73
  74 (defun riece-ctlseq-face-foreground-name (face)
  75   "Return the name of FACE's foreground color."
  76   (if (fboundp 'face-foreground-name)   ;XEmacs
  77       (face-foreground-name face)
  78     (face-foreground face)))
  79
  80 (defun riece-ctlseq-face-background-name (face)
  81   "Return the name of FACE's background color."
  82   (if (fboundp 'face-background-name)   ;XEmacs
  83       (face-background-name face)
  84     (face-background face)))
  85
  86 (defun riece-ctlseq-make-face (attrs)
  87   (let* ((face-name (intern (format "riece-ctlseq-face-%d"
  88                                     (prog1 riece-ctlseq-face-counter
  89                                       (setq riece-ctlseq-face-counter
  90                                             (1+ riece-ctlseq-face-counter))))))
  91          (face (make-face face-name))
  92          foreground
  93          background)
  94     (if (plist-get attrs 'bold)
  95         (make-face-bold face))
  96     (if (plist-get attrs 'underline)
  97         (set-face-underline-p face t))
  98     (if (setq foreground (plist-get attrs 'foreground))
  99         (set-face-foreground face foreground))
 100     (if (setq background (plist-get attrs 'background))
 101         (set-face-background face background))
 102     (when (plist-get attrs 'inverse-video)
 103       (setq foreground (or (riece-ctlseq-face-background-name face)
 104                            (riece-ctlseq-face-background-name 'default))
 105             background (or (riece-ctlseq-face-foreground-name face)
 106                            (riece-ctlseq-face-foreground-name 'default)))
 107       (set-face-foreground face foreground)
 108       (set-face-background face background))
 109     (put face-name 'riece-ctlseq-attributes attrs)
 110     face-name))
 111
 112 (defun riece-ctlseq-face-from-cache (attrs)
 113   (if (null attrs)
 114       'default
 115     (let ((pointer riece-ctlseq-face-cache)
 116           last-pointer
 117           other)
 118       (catch 'found
 119         (while pointer
 120           (setq other (get (car pointer) 'riece-ctlseq-attributes))
 121           (when (and (riece-ctlseq-compatible-attributes-p attrs other)
 122                      (riece-ctlseq-compatible-attributes-p other attrs))
 123             (if last-pointer
 124                 (setcdr last-pointer (cdr pointer)))
 125             (throw 'found (setcar riece-ctlseq-face-cache (car pointer))))
 126           (setq last-pointer pointer
 127                 pointer (cdr pointer)))
 128         (if (>= (length riece-ctlseq-face-cache)
 129                 riece-ctlseq-face-cache-size)
 130             (setq riece-ctlseq-face-cache
 131                   (butlast riece-ctlseq-face-cache)))
 132         (setq riece-ctlseq-face-cache
 133               (cons (riece-ctlseq-make-face attrs)
 134                     riece-ctlseq-face-cache))
 135         (car riece-ctlseq-face-cache)))))
 136
 137 (defun riece-ctlseq-update-attributes (tag attrs)
 138   (cond
 139    ((eq (aref tag 0) ?\x2)              ;^B
 140     (plist-put attrs 'bold (not (plist-get attrs 'bold))))
 141    ((eq (aref tag 0) ?\xF))             ;^O
 142    ((eq (aref tag 0) ?\x16)             ;^V
 143     (plist-put attrs 'inverse-video (not (plist-get attrs 'inverse-video))))
 144    ((eq (aref tag 0) ?\x1F)             ;^_
 145     (plist-put attrs 'underline (not (plist-get attrs 'underline))))
 146    ((string-match "\x3\\([0-9]+\\)?\\(,[0-9]+\\)?" tag) ;^C<fg>,<bg>
 147     (if (match-beginning 1)
 148         (setq attrs (plist-put attrs 'foreground
 149                                (nth (string-to-number (match-string 1 tag))
 150                                     riece-ctlseq-colors))))
 151     (if (match-beginning 2)
 152         (setq attrs (plist-put attrs 'background
 153                                (nth (string-to-number
 154                                      (substring (match-string 2 tag) 1))
 155                                     riece-ctlseq-colors))))
 156     attrs)))
 157
 158 (defun riece-ctlseq-message-filter (message)
 159   (if riece-ctlseq-enabled
 160       (let ((start 0)
 161             (end (length (riece-message-text message)))
 162             attrs)
 163         (while (string-match
 164                 "[\x2\xF\x16\x1F]\\|\x3\\([0-9]+\\)?\\(,[0-9]+\\)?"
 165                 (riece-message-text message) start)
 166           (if riece-ctlseq-hide-controls
 167               (put-text-property (match-beginning 0) (match-end 0)
 168                                  'invisible 'riece-ctlseq
 169                                  (riece-message-text message)))
 170           (if attrs
 171               (put-text-property start (match-beginning 0)
 172                                  'riece-ctlseq-attributes (copy-sequence attrs)
 173                                  (riece-message-text message)))
 174           (setq start (match-end 0)
 175                 attrs (riece-ctlseq-update-attributes
 176                        (match-string 0 (riece-message-text message)) attrs)))
 177         (if (and (< start end) attrs)
 178             (put-text-property start end
 179                                'riece-overlay-face
 180                                (riece-ctlseq-face-from-cache attrs)
 181                                (riece-message-text message)))))
 182   message)
 183
 184 (defun riece-ctlseq-requires ()
 185   '(riece-highlight))
 186
 187 (defun riece-ctlseq-insinuate ()
 188   (add-hook 'riece-message-filter-functions 'riece-ctlseq-message-filter))
 189
 190 (defun riece-ctlseq-enable ()
 191   (setq riece-ctlseq-enabled t))
 192
 193 (defun riece-ctlseq-disable ()
 194   (setq riece-ctlseq-enabled nil))
 195
 196 (provide 'riece-ctlseq)
 197
 198 ;;; riece-ctlseq.el ends here