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