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
  45 To set up colors compatible with X-Chat and mIRC, do:
  46 \(setq riece-ctlseq-colors '(\"#cecece\" \"black\" \"#0000cc\" \"#00cc00\"
  47                             \"#dd0000\" \"#aa0000\" \"#bb00bb\" \"#ffaa00\"
  48                             \"#eedd22\" \"#33de55\" \"#00cccc\" \"#33eeff\"
  49                             \"#0000ff\" \"#ee22ee\" \"#777777\" \"#999999\"))
  50 "
  51   :group 'riece-ctlseq
  52   :type '(repeat (string :tag "Color")))
  53
  54 (defcustom riece-ctlseq-hide-controls t
  55   "If non-nil, control characters are hidden."
  56   :group 'riece-ctlseq
  57   :type 'boolean)
  58
  59 (defcustom riece-ctlseq-face-cache-size 128
  60   "Maximum length of the internal face cache."
  61   :group 'riece-ctlseq
  62   :type 'integer)
  63
  64 (defvar riece-ctlseq-face-cache nil)
  65 (defvar riece-ctlseq-face-counter 0)
  66
  67 (defconst riece-ctlseq-description
  68   "Mark up control sequences in IRC buffers.")
  69
  70 (defconst riece-ctlseq-regexp
  71   "[\x2\xF\x16\x1F]\\|\x3\\([0-9][0-9]?\\)\\(,[0-9][0-9]?\\)?")
  72
  73 (defun riece-ctlseq-compatible-attributes-p (this other)
  74   (let ((pointer this))
  75     (catch 'mismatched
  76       (while pointer
  77         (unless (equal (plist-get other (car pointer)) (nth 1 pointer))
  78           (throw 'mismatched nil))
  79         (setq pointer (nthcdr 2 pointer)))
  80       t)))
  81
  82 (defun riece-ctlseq-face-foreground-name (face)
  83   "Return the name of FACE's foreground color."
  84   (if (fboundp 'face-foreground-name)   ;XEmacs
  85       (face-foreground-name face)
  86     (face-foreground face)))
  87
  88 (defun riece-ctlseq-face-background-name (face)
  89   "Return the name of FACE's background color."
  90   (if (fboundp 'face-background-name)   ;XEmacs
  91       (face-background-name face)
  92     (face-background face)))
  93
  94 (defun riece-ctlseq-make-face (attrs)
  95   (let* ((face-name (intern (format "riece-ctlseq-face-%d"
  96                                     (prog1 riece-ctlseq-face-counter
  97                                       (setq riece-ctlseq-face-counter
  98                                             (1+ riece-ctlseq-face-counter))))))
  99          (face (make-face face-name))
 100          foreground
 101          background)
 102     (if (plist-get attrs 'bold)
 103         (make-face-bold face))
 104     (if (plist-get attrs 'underline)
 105         (set-face-underline-p face t))
 106     (if (setq foreground (plist-get attrs 'foreground))
 107         (set-face-foreground face foreground))
 108     (if (setq background (plist-get attrs 'background))
 109         (set-face-background face background))
 110     (when (plist-get attrs 'inverse-video)
 111       (setq foreground (or (riece-ctlseq-face-background-name face)
 112                            (riece-ctlseq-face-background-name 'default))
 113             background (or (riece-ctlseq-face-foreground-name face)
 114                            (riece-ctlseq-face-foreground-name 'default)))
 115       (set-face-foreground face foreground)
 116       (set-face-background face background))
 117     (put face-name 'riece-ctlseq-attributes attrs)
 118     face-name))
 119
 120 (defun riece-ctlseq-face-from-cache (attrs)
 121   (if (null attrs)
 122       'default
 123     (let ((pointer riece-ctlseq-face-cache)
 124           last-pointer
 125           other)
 126       (catch 'found
 127         (while pointer
 128           (setq other (get (car pointer) 'riece-ctlseq-attributes))
 129           (when (and (riece-ctlseq-compatible-attributes-p attrs other)
 130                      (riece-ctlseq-compatible-attributes-p other attrs))
 131             (if last-pointer
 132                 (setcdr last-pointer (cdr pointer)))
 133             (throw 'found (setcar riece-ctlseq-face-cache (car pointer))))
 134           (setq last-pointer pointer
 135                 pointer (cdr pointer)))
 136         (if (>= (length riece-ctlseq-face-cache)
 137                 riece-ctlseq-face-cache-size)
 138             (setq riece-ctlseq-face-cache
 139                   (butlast riece-ctlseq-face-cache)))
 140         (setq riece-ctlseq-face-cache
 141               (cons (riece-ctlseq-make-face attrs)
 142                     riece-ctlseq-face-cache))
 143         (car riece-ctlseq-face-cache)))))
 144
 145 (defun riece-ctlseq-update-attribute (tag attrs)
 146   (let ((attrs (copy-sequence attrs)))
 147     (cond
 148      ((eq (aref tag 0) ?\x2)            ;^B
 149       (setq attrs (plist-put attrs 'bold (not (plist-get attrs 'bold)))))
 150      ((eq (aref tag 0) ?\xF)            ;^O
 151       (setq attrs nil))
 152      ((eq (aref tag 0) ?\x16)           ;^V
 153       (setq attrs (plist-put attrs 'inverse-video
 154                              (not (plist-get attrs 'inverse-video)))))
 155      ((eq (aref tag 0) ?\x1F)           ;^_
 156       (setq attrs (plist-put attrs 'underline
 157                              (not (plist-get attrs 'underline)))))
 158      ((eq (aref tag 0) ?\x3)            ;^C<fg>[,<bg>]
 159       (setq attrs (plist-put attrs 'foreground
 160                              (nth (string-to-number (substring tag 1))
 161                                   riece-ctlseq-colors)))
 162       (if (string-match "," tag)
 163           (setq attrs (plist-put attrs 'background
 164                                  (nth (string-to-number
 165                                        (substring tag (match-end 0)))
 166                                       riece-ctlseq-colors))))))
 167     attrs))
 168
 169 (defun riece-ctlseq-update-attributes (tags attrs)
 170   (let ((start 0))
 171     (while (string-match riece-ctlseq-regexp tags start)
 172       (setq start (match-end 0)
 173             attrs (riece-ctlseq-update-attribute (match-string 0 tags) attrs)))
 174     attrs))
 175
 176 (defun riece-ctlseq-put-attributes (string start end attrs)
 177   (when (and (> end start) attrs)
 178     (put-text-property start end
 179                        'riece-ctlseq-attributes (copy-sequence attrs)
 180                        (riece-message-text message))
 181     (put-text-property start end
 182                        'riece-overlay-face
 183                        (riece-ctlseq-face-from-cache attrs)
 184                        (riece-message-text message))))
 185
 186 (defun riece-ctlseq-message-filter (message)
 187   (if (get 'riece-ctlseq 'riece-addon-enabled)
 188       (let ((start 0)
 189             (end (length (riece-message-text message)))
 190             tags-start tags-end attrs)
 191         (while (string-match (concat "\\(" riece-ctlseq-regexp "\\)+")
 192                              (riece-message-text message) start)
 193           (if riece-ctlseq-hide-controls
 194               (put-text-property (match-beginning 0) (match-end 0)
 195                                  'invisible 'riece-ctlseq
 196                                  (riece-message-text message)))
 197           (setq tags-start (match-beginning 0)
 198                 tags-end (match-end 0))
 199           (riece-ctlseq-put-attributes (riece-message-text message)
 200                                        start tags-start
 201                                        attrs)
 202           (setq attrs (riece-ctlseq-update-attributes
 203                        (substring (riece-message-text message)
 204                                   tags-start tags-end)
 205                        attrs)
 206                 start tags-end))
 207         (riece-ctlseq-put-attributes (riece-message-text message)
 208                                      start end
 209                                      attrs)))
 210   message)
 211
 212 (defun riece-ctlseq-requires ()
 213   '(riece-highlight))
 214
 215 (defun riece-ctlseq-insinuate ()
 216   (add-hook 'riece-message-filter-functions 'riece-ctlseq-message-filter))
 217
 218 (defun riece-ctlseq-uninstall ()
 219   (remove-hook 'riece-message-filter-functions 'riece-ctlseq-message-filter))
 220
 221 (provide 'riece-ctlseq)
 222
 223 ;;; riece-ctlseq.el ends here