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 (defun riece-ctlseq-compatible-attributes-p (this other)
  61   (let ((pointer this))
  62     (catch 'mismatched
  63       (while pointer
  64         (unless (equal (plist-get other (car pointer)) (nth 1 pointer))
  65           (throw 'mismatched nil))
  66         (setq pointer (nthcdr 2 pointer)))
  67       t)))
  68
  69 (defun riece-ctlseq-face-foreground-name (face)
  70   "Return the name of FACE's foreground color."
  71   (if (fboundp 'face-foreground-name)   ;XEmacs
  72       (face-foreground-name face)
  73     (face-foreground face)))
  74
  75 (defun riece-ctlseq-face-background-name (face)
  76   "Return the name of FACE's background color."
  77   (if (fboundp 'face-background-name)   ;XEmacs
  78       (face-background-name face)
  79     (face-background face)))
  80
  81 (defun riece-ctlseq-make-face (attrs)
  82   (let* ((face-name (intern (format "riece-ctlseq-face-%d"
  83                                     (prog1 riece-ctlseq-face-counter
  84                                       (setq riece-ctlseq-face-counter
  85                                             (1+ riece-ctlseq-face-counter))))))
  86          (face (make-face face-name))
  87          foreground
  88          background)
  89     (if (plist-get attrs 'bold)
  90         (make-face-bold face))
  91     (if (plist-get attrs 'underline)
  92         (set-face-underline-p face t))
  93     (if (setq foreground (plist-get attrs 'foreground))
  94         (set-face-foreground face foreground))
  95     (if (setq background (plist-get attrs 'background))
  96         (set-face-background face background))
  97     (when (plist-get attrs 'inverse-video)
  98       (setq foreground (or (riece-ctlseq-face-background-name face)
  99                            (riece-ctlseq-face-background-name 'default))
 100             background (or (riece-ctlseq-face-foreground-name face)
 101                            (riece-ctlseq-face-foreground-name 'default)))
 102       (set-face-foreground face foreground)
 103       (set-face-background face background))
 104     (put face-name 'riece-ctlseq-attributes attrs)
 105     face-name))
 106
 107 (defun riece-ctlseq-face-from-cache (attrs)
 108   (if (null attrs)
 109       'default
 110     (let ((pointer riece-ctlseq-face-cache)
 111           last-pointer
 112           other)
 113       (catch 'found
 114         (while pointer
 115           (setq other (get (car pointer) 'riece-ctlseq-attributes))
 116           (when (and (riece-ctlseq-compatible-attributes-p attrs other)
 117                      (riece-ctlseq-compatible-attributes-p other attrs))
 118             (if last-pointer
 119                 (setcdr last-pointer (cdr pointer)))
 120             (throw 'found (setcar riece-ctlseq-face-cache (car pointer))))
 121           (setq last-pointer pointer
 122                 pointer (cdr pointer)))
 123         (if (>= (length riece-ctlseq-face-cache)
 124                 riece-ctlseq-face-cache-size)
 125             (setq riece-ctlseq-face-cache
 126                   (butlast riece-ctlseq-face-cache)))
 127         (setq riece-ctlseq-face-cache
 128               (cons (riece-ctlseq-make-face attrs)
 129                     riece-ctlseq-face-cache))
 130         (car riece-ctlseq-face-cache)))))
 131
 132 (defun riece-ctlseq-update-attributes (tag attrs)
 133   (cond
 134    ((eq (aref tag 0) ?\x2)              ;^B
 135     (plist-put attrs 'bold (not (plist-get attrs 'bold))))
 136    ((eq (aref tag 0) ?\xF))             ;^O
 137    ((eq (aref tag 0) ?\x16)             ;^V
 138     (plist-put attrs 'inverse-video (not (plist-get attrs 'inverse-video))))
 139    ((eq (aref tag 0) ?\x1F)             ;^_
 140     (plist-put attrs 'underline (not (plist-get attrs 'underline))))
 141    ((string-match "\x3\\([0-9]+\\)?\\(,[0-9]+\\)?" tag) ;^C<fg>,<bg>
 142     (if (match-beginning 1)
 143         (setq attrs (plist-put attrs 'foreground
 144                                (nth (string-to-number (match-string 1 tag))
 145                                     riece-ctlseq-colors))))
 146     (if (match-beginning 2)
 147         (setq attrs (plist-put attrs 'background
 148                                (nth (string-to-number
 149                                      (substring (match-string 2 tag) 1))
 150                                     riece-ctlseq-colors))))
 151     attrs)))
 152
 153 (defun riece-ctlseq-message-filter (message)
 154   (let ((start 0)
 155         (end (length (riece-message-text message)))
 156         attrs)
 157     (while (string-match
 158             "[\x2\xF\x16\x1F]\\|\x3\\([0-9]+\\)?\\(,[0-9]+\\)?"
 159             (riece-message-text message) start)
 160       (if riece-ctlseq-hide-controls
 161           (put-text-property (match-beginning 0) (match-end 0)
 162                              'invisible 'riece-ctlseq
 163                              (riece-message-text message)))
 164       (if attrs
 165           (put-text-property start (match-beginning 0)
 166                              'riece-ctlseq-attributes (copy-sequence attrs)
 167                              (riece-message-text message)))
 168       (setq start (match-end 0)
 169             attrs (riece-ctlseq-update-attributes
 170                    (match-string 0 (riece-message-text message)) attrs)))
 171     (if (and (< start end) attrs)
 172         (put-text-property start end
 173                            'riece-overlay-face
 174                            (riece-ctlseq-face-from-cache attrs)
 175                            (riece-message-text message))))
 176   message)
 177
 178 (defun riece-ctlseq-requires ()
 179   '(riece-highlight))
 180
 181 (defun riece-ctlseq-insinuate ()
 182   (add-hook 'riece-message-filter-functions 'riece-ctlseq-message-filter))
 183
 184 (provide 'riece-ctlseq)
 185
 186 ;;; riece-ctlseq.el ends here