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