cgit.sxemacs.org Git - riece/blob - lisp/riece-ctlseq.el

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