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