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 (defconst riece-ctlseq-regexp
  64   "[\x2\xF\x16\x1F]\\|\x3\\([0-9]+\\)?\\(,[0-9]+\\)?")
  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-attribute (tag attrs)
 139   (let ((attrs (copy-sequence attrs)))
 140     (cond
 141      ((eq (aref tag 0) ?\x2)            ;^B
 142       (setq attrs (plist-put attrs 'bold (not (plist-get attrs 'bold)))))
 143      ((eq (aref tag 0) ?\xF)            ;^O
 144       (setq attrs nil))
 145      ((eq (aref tag 0) ?\x16)           ;^V
 146       (setq attrs (plist-put attrs 'inverse-video
 147                              (not (plist-get attrs 'inverse-video)))))
 148      ((eq (aref tag 0) ?\x1F)           ;^_
 149       (setq attrs (plist-put attrs 'underline
 150                              (not (plist-get attrs 'underline)))))
 151      ((string-match "\x3\\([0-9]+\\)?\\(,[0-9]+\\)?" tag) ;^C<fg>,<bg>
 152       (if (match-beginning 1)
 153           (setq attrs (plist-put attrs 'foreground
 154                                  (nth (string-to-number (match-string 1 tag))
 155                                       riece-ctlseq-colors))))
 156       (if (match-beginning 2)
 157           (setq attrs (plist-put attrs 'background
 158                                  (nth (string-to-number
 159                                        (substring (match-string 2 tag) 1))
 160                                       riece-ctlseq-colors))))))
 161     attrs))
 162
 163 (defun riece-ctlseq-update-attributes (tags attrs)
 164   (let ((start 0))
 165     (while (string-match riece-ctlseq-regexp tags start)
 166       (setq start (match-end 0)
 167             attrs (riece-ctlseq-update-attribute (match-string 0 tags) attrs)))
 168     attrs))
 169
 170 (defun riece-ctlseq-put-attributes (string start end attrs)
 171   (when (and (> end start) attrs)
 172     (put-text-property start end
 173                        'riece-ctlseq-attributes (copy-sequence attrs)
 174                        (riece-message-text message))
 175     (put-text-property start end
 176                        'riece-overlay-face
 177                        (riece-ctlseq-face-from-cache attrs)
 178                        (riece-message-text message))))
 179
 180 (defun riece-ctlseq-message-filter (message)
 181   (if (get 'riece-ctlseq 'riece-addon-enabled)
 182       (let ((start 0)
 183             (end (length (riece-message-text message)))
 184             tags-start tags-end attrs)
 185         (while (string-match (concat "\\(" riece-ctlseq-regexp "\\)+")
 186                              (riece-message-text message) start)
 187           (if riece-ctlseq-hide-controls
 188               (put-text-property (match-beginning 0) (match-end 0)
 189                                  'invisible 'riece-ctlseq
 190                                  (riece-message-text message)))
 191           (setq tags-start (match-beginning 0)
 192                 tags-end (match-end 0))
 193           (riece-ctlseq-put-attributes (riece-message-text message)
 194                                        start tags-start
 195                                        attrs)
 196           (setq attrs (riece-ctlseq-update-attributes
 197                        (substring (riece-message-text message)
 198                                   tags-start tags-end)
 199                        attrs)
 200                 start tags-end))
 201         (riece-ctlseq-put-attributes (riece-message-text message)
 202                                      start end
 203                                      attrs)))
 204   message)
 205
 206 (defun riece-ctlseq-requires ()
 207   '(riece-highlight))
 208
 209 (defun riece-ctlseq-insinuate ()
 210   (add-hook 'riece-message-filter-functions 'riece-ctlseq-message-filter))
 211
 212 (defun riece-ctlseq-uninstall ()
 213   (remove-hook 'riece-message-filter-functions 'riece-ctlseq-message-filter))
 214
 215 (provide 'riece-ctlseq)
 216
 217 ;;; riece-ctlseq.el ends here