lisp/liece-hilit.el

   1 ;;; liece-hilit.el --- coloring IRC buffers
   2 ;; Copyright (C) 1998-2000 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1998-09-28
   6 ;; Revised: 1998-11-25
   7 ;; Keywords: IRC, liece
   8
   9 ;; This file is part of Liece.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31
  32 (require 'invisible)
  33
  34 (eval-when-compile
  35   (require 'liece-inlines)
  36   (require 'font-lock))
  37
  38 (autoload 'liece-url-add-buttons "liece-url")
  39 (autoload 'liece-channel-add-buttons "liece-channel")
  40 (autoload 'liece-nick-add-buttons "liece-nick")
  41
  42 (defgroup liece-highlight nil
  43   "Highlight your IRC buffer"
  44   :tag "Highlight"
  45   :prefix "liece-"
  46   :group 'liece)
  47
  48 (defgroup liece-highlight-faces nil
  49   "Faces for highlight your IRC buffer"
  50   :tag "Faces"
  51   :prefix "liece-highlight-"
  52   :group 'liece-highlight)
  53
  54 (defcustom liece-change-face 'liece-change-face
  55   "Face used for displaying \"*** Change:\" line."
  56   :type 'face
  57   :group 'liece-highlight-faces)
  58
  59 (defcustom liece-notice-face 'liece-notice-face
  60   "Face used for displaying \"*** Notice:\" line."
  61   :type 'face
  62   :group 'liece-highlight-faces)
  63
  64 (defcustom liece-broadcast-face 'liece-broadcast-face
  65   "Face used for displaying \"*** Broadcast:\" line."
  66   :type 'face
  67   :group 'liece-highlight-faces)
  68
  69 (defcustom liece-wallops-face 'liece-wallops-face
  70   "Face used for displaying \"*** Wallops:\" line."
  71   :type 'face
  72   :group 'liece-highlight-faces)
  73
  74 (defcustom liece-error-face 'liece-error-face
  75   "Face used for displaying \"*** Error:\" line."
  76   :type 'face
  77   :group 'liece-highlight-faces)
  78
  79 (defcustom liece-info-face 'liece-info-face
  80   "Face used for displaying \"*** Info:\" line."
  81   :type 'face
  82   :group 'liece-highlight-faces)
  83
  84 (defcustom liece-timestamp-face 'liece-timestamp-face
  85   "Face used for displaying \"*** Time:\" line."
  86   :type 'face
  87   :group 'liece-highlight-faces)
  88
  89 (defcustom liece-client-face 'liece-client-face
  90   "Face used for displaying \"CLIENT@\" line."
  91   :type 'face
  92   :group 'liece-highlight-faces)
  93
  94 (defcustom liece-dcc-face 'liece-dcc-face
  95   "Face used for displaying \"*** DCC:\" line."
  96   :type 'face
  97   :group 'liece-highlight-faces)
  98
  99 (defcustom liece-prefix-face 'liece-prefix-face
 100   "Face used for displaying \"<nick>\" extent."
 101   :type 'face
 102   :group 'liece-highlight-faces)
 103
 104 (defcustom liece-priv-prefix-face 'liece-priv-prefix-face
 105   "Face used for displaying \"=nick\" line."
 106   :type 'face
 107   :group 'liece-highlight-faces)
 108
 109 (defcustom liece-pattern-face 'liece-pattern-face
 110   "Face used for displaying user defined pattern."
 111   :type 'face
 112   :group 'liece-highlight-faces)
 113
 114 (defcustom liece-quoted-bold-face 'liece-quoted-bold-face
 115   "Face used for displaying \002 quoted string."
 116   :type 'face
 117   :group 'liece-highlight-faces)
 118
 119 (defcustom liece-quoted-inverse-face 'liece-quoted-inverse-face
 120   "Face used for displaying \026 quoted string."
 121   :type 'face
 122   :group 'liece-highlight-faces)
 123
 124 (defcustom liece-quoted-underline-face 'liece-quoted-underline-face
 125   "Face used for displaying \037 quoted string."
 126   :type 'face
 127   :group 'liece-highlight-faces)
 128
 129 (defcustom liece-quoted-colors-ircle
 130   '("white" "black" "red" "orange" "yellow" "LightGreen" "DarkOliveGreen"
 131     "cyan4" "turquoise" "blue" "black" "black" "black" "black" "black"
 132     "DarkBlue" "purple1" "purple2" "purple3" "magenta")
 133   "Color list for displaying \003 quoted string."
 134   :type '(list (radio string face))
 135   :group 'liece-highlight)
 136
 137 (defcustom liece-quoted-colors-mirc
 138   '("white" "black" "blue" "DarkOliveGreen" "red" "brown" "purple"
 139     "orange" "yellow" "green" "cyan4" "turquoise" "RoyalBlue" "HotPink"
 140     "gray50" "gray75" "black" "black" "black" "black")
 141   "Color list for displaying \013 quoted string."
 142   :type '(list (radio string face))
 143   :group 'liece-highlight)
 144
 145 (defcustom liece-highlight-jingle-function nil
 146   "Function playing jingles."
 147   :type 'function
 148   :group 'liece-highlight)
 149
 150 (defface liece-change-face
 151   '((((class color)
 152       (background dark))
 153      (:foreground "cyan" :bold t))
 154     (((class color)
 155       (background light))
 156      (:foreground "RoyalBlue" :bold t))
 157     (t
 158      (:bold t)))
 159   "Face used for displaying \"*** Change:\" line"
 160   :group 'liece-highlight-faces)
 161
 162 (defface liece-notice-face
 163   '((((class color)
 164       (background dark))
 165      (:foreground "green2" :bold t))
 166     (((class color)
 167       (background light))
 168      (:foreground "MidnightBlue" :bold t))
 169     (t
 170      (:bold t)))
 171   "Face used for displaying \"*** Notice:\" line"
 172   :group 'liece-highlight-faces)
 173
 174 (defface liece-broadcast-face
 175   '((((class color)
 176       (background dark))
 177      (:foreground "Plum1" :italic t))
 178     (((class color)
 179       (background light))
 180      (:foreground "purple" :italic t))
 181     (t
 182      (:italic t)))
 183   "Face used for displaying \"*** Broadcast:\" line"
 184   :group 'liece-highlight-faces)
 185
 186 (defface liece-wallops-face
 187   '((((class color)
 188       (background dark))
 189      (:foreground "yellow" :bold t))
 190     (((class color)
 191       (background light))
 192      (:foreground "blue4" :bold t))
 193     (t
 194      (:bold t)))
 195   "Face used for displaying \"*** Wallops:\" line"
 196   :group 'liece-highlight-faces)
 197
 198 (defface liece-error-face
 199   '((((class color)
 200       (background dark))
 201      (:foreground "cornflower blue" :bold t))
 202     (((class color)
 203       (background light))
 204      (:foreground "DarkGreen"))
 205     (t
 206      (:bold t)))
 207   "Face used for displaying \"*** Error:\" line"
 208   :group 'liece-highlight-faces)
 209
 210 (defface liece-info-face
 211   '((((class color)
 212       (background dark))
 213      (:foreground "PaleTurquoise" :bold t))
 214     (((class color)
 215       (background light))
 216      (:foreground "RoyalBlue"))
 217     (t
 218      (:bold t)))
 219   "Face used for displaying \"*** Info:\" line"
 220   :group 'liece-highlight-faces)
 221
 222 (defface liece-timestamp-face
 223   '((((class color)
 224       (background dark))
 225      (:foreground "yellow" :bold t))
 226     (((class color)
 227       (background light))
 228      (:foreground "blue4" :bold t))
 229     (t
 230      (:bold t)))
 231   "Face used for displaying \"*** Time:\" line"
 232   :group 'liece-highlight-faces)
 233
 234 (defface liece-client-face
 235   '((((class color)
 236       (background dark))
 237      (:foreground "orange"))
 238     (((class color)
 239       (background light))
 240      (:foreground "red"))
 241     (t
 242      (:bold nil)))
 243   "Face used for displaying \"CLIENT@\" line"
 244   :group 'liece-highlight-faces)
 245
 246 (defface liece-dcc-face
 247   '((((class color)
 248       (background dark))
 249      (:foreground "orange"))
 250     (((class color)
 251       (background light))
 252      (:foreground "red"))
 253     (t
 254      (:bold nil)))
 255   "Face used for displaying \"*** DCC:\" line"
 256   :group 'liece-highlight-faces)
 257
 258 (defface liece-prefix-face
 259   '((((class color)
 260       (background dark))
 261      (:foreground "moccasin"))
 262     (((class color)
 263       (background light))
 264      (:foreground "firebrick"))
 265     (t
 266      (:bold nil)))
 267   "Face used for displaying \"<nick>\" extent"
 268   :group 'liece-highlight-faces)
 269
 270 (defface liece-priv-prefix-face
 271   '((((class color)
 272       (background dark))
 273      (:foreground "orange"))
 274     (((class color)
 275       (background light))
 276      (:foreground "grey40"))
 277     (t
 278      (:bold nil)))
 279   "Face used for displaying \"=nick\" line"
 280   :group 'liece-highlight-faces)
 281
 282 (defface liece-pattern-face
 283   '((((class color)
 284       (background dark))
 285      (:foreground "red"))
 286     (((class color)
 287       (background light))
 288      (:foreground "red"))
 289     (t
 290      (:bold nil)))
 291   "Face used for displaying user defined pattern"
 292   :group 'liece-highlight-faces)
 293
 294 (defface liece-quoted-bold-face
 295   '((t (:bold t)))
 296   "Face used for displaying \002 quoted string"
 297   :group 'liece-highlight-faces)
 298
 299 (defface liece-quoted-inverse-face
 300   '((t (:inverse-video t)))
 301   "Face used for displaying \026 quoted string"
 302   :group 'liece-highlight-faces)
 303
 304 (defface liece-quoted-underline-face
 305   '((t (:underline t)))
 306   "Face used for displaying \037 quoted string"
 307   :group 'liece-highlight-faces)
 308
 309 (defcustom liece-highlight-font-lock-keywords
 310   (append
 311    ;; setting property occurred once
 312    (list
 313     `(,(concat
 314         "^\\(" liece-time-prefix-regexp "\\)?"
 315         "\\(\\([][<>(-][][<>(-]?[^ <>)]*[][<>)-][][<>)-]?\\)\\|"
 316         "\\(=[^ ]*=\\|\\*\\*[^ \*]*\\*\\*\\)\\) ")
 317       (3 liece-prefix-face append t)
 318       (4 liece-priv-prefix-face append t)
 319       ("\\(\002\\)\\([^\002\026\037\003]*\\)" nil nil
 320        (2 liece-quoted-bold-face t t))
 321       ("\\(\026\\)\\([^\002\026\037\003]*\\)" nil nil
 322        (2 liece-quoted-inverse-face t t))
 323       ("\\(\037\\)\\([^\002\026\037\003]*\\)" nil nil
 324        (2 liece-quoted-underline-face t t))))
 325    ;; set property whole line
 326    (mapcar
 327     (lambda (line)
 328       (cons
 329        (concat
 330         "^\\(" liece-time-prefix-regexp "\\)?\\("
 331         (regexp-quote
 332          (symbol-value (intern (format "liece-%s-prefix" line))))
 333         ".*\\)$")
 334        (list 2 (intern (format "liece-%s-face" line)) t t)))
 335     '(change notice broadcast wallops error info timestamp client dcc))
 336    '((eval . (cons liece-highlight-pattern liece-pattern-face))))
 337   "Normal and deformed faces for IRC normal line."
 338   :type '(repeat (list string))
 339   :group 'liece-highlight)
 340
 341 (put 'liece-channel-mode 'font-lock-defaults
 342      '(liece-highlight-font-lock-keywords t))
 343 (put 'liece-others-mode 'font-lock-defaults
 344      '(liece-highlight-font-lock-keywords t))
 345 (put 'liece-dialogue-mode 'font-lock-defaults
 346      '(liece-highlight-font-lock-keywords t))
 347
 348 ;;; This is a kludge for fontifying buffer whose name starts with a space.
 349 ;;; Font-lock isn't responsible for (maybe) invisible buffers.
 350 (defadvice font-lock-mode
 351   (around liece-replace-space-in-buffer-name activate)
 352   (if (char-equal (aref (buffer-name) 0) ? )
 353       (unwind-protect
 354           (progn
 355             (aset (buffer-name) 0 ?_)
 356             ad-do-it)
 357         (aset (buffer-name) 0 ? ))
 358     ad-do-it))
 359
 360 (add-hook 'liece-after-load-startup-hook
 361           'liece-highlight-maybe-turn-on-font-lock)
 362
 363 (defun liece-highlight-maybe-turn-on-font-lock ()
 364   (when liece-highlight-mode
 365     (add-hook 'liece-channel-mode-hook
 366               'liece-highlight-turn-on-font-lock)
 367     (add-hook 'liece-others-mode-hook
 368               'liece-highlight-turn-on-font-lock)
 369     (add-hook 'liece-dialogue-mode-hook
 370               'liece-highlight-turn-on-font-lock)
 371     (add-hook 'liece-after-insert-functions 'liece-url-add-buttons)
 372     (add-hook 'liece-after-insert-functions 'liece-channel-add-buttons)
 373     ;;(add-hook 'liece-after-insert-functions 'liece-nick-add-buttons)
 374     ))
 375
 376 (defun liece-highlight-turn-on-font-lock ()
 377   (make-local-variable 'font-lock-defaults)
 378   (setq font-lock-defaults '(liece-highlight-font-lock-keywords t))
 379   (make-local-variable 'font-lock-verbose)
 380   (setq font-lock-verbose nil)
 381   (make-local-variable 'font-lock-support-mode)
 382   (setq font-lock-support-mode nil)
 383   (make-local-hook 'font-lock-mode-hook)
 384   (setq font-lock-mode-hook nil)
 385   (turn-on-font-lock)
 386   (make-local-hook 'after-change-functions)
 387   (or liece-display-prefix-tag
 388       (add-hook 'after-change-functions
 389                 'liece-highlight-maybe-hide-prefix nil 'local))
 390   (add-hook 'after-change-functions
 391             'liece-highlight-colorize-quote nil 'local)
 392   (add-hook 'after-change-functions
 393             'liece-highlight-maybe-hide-quote 'append 'local)
 394   (when (and (eq major-mode 'liece-dialogue-mode)
 395              (liece-functionp liece-highlight-jingle-function))
 396     (add-hook 'after-change-functions
 397               'liece-highlight-maybe-play-jingle 'append 'local)))
 398
 399 (defun liece-highlight-maybe-hide-prefix (st nd len)
 400   (save-excursion
 401     (goto-char st)
 402     (if (looking-at liece-generic-prefix-tag-regexp)
 403         (invisible-region
 404          (match-beginning 1) (match-end 1)))))
 405
 406 (defun liece-highlight-maybe-hide-quote (st nd len)
 407   (save-excursion
 408     (goto-char st)
 409     (while (re-search-forward "[\002\026\037]\\|[\003\013][0-9:;<=]+" nd t)
 410       (invisible-region
 411        (match-beginning 0) (match-end 0)))))
 412
 413 (defun liece-highlight-maybe-play-jingle (st nd len)
 414   (save-excursion
 415     (goto-char st)
 416     (when (re-search-forward
 417            (if (listp liece-highlight-pattern)
 418                (car liece-highlight-pattern)
 419              liece-highlight-pattern)
 420            nd t)
 421       (funcall liece-highlight-jingle-function))))
 422
 423 (defun liece-highlight-colorize-quote (st nd len)
 424   (save-excursion
 425     (goto-char st)
 426     (let (num face faces vender name ovl)
 427       (while (re-search-forward "\\([\003\013][0-9:;<=]+\\)\\([^\002\026\037\003\013]*\\)" nd t)
 428         (setq ovl (make-overlay (match-beginning 2) (match-end 2))
 429               num (match-string 1)
 430               vender (cond ((eq ?\003 (aref num 0)) 'ircle)
 431                            ((eq ?\013 (aref num 0)) 'mirc))
 432               num (if (< 57 (char-int (aref num 1)))
 433                       (- (char-int (aref num 1)) 43)
 434                     (string-to-int (substring num 1)))
 435               faces (nthcdr num (symbol-value
 436                                  (intern (format "liece-quoted-colors-%s"
 437                                                  vender))))
 438               face (car faces))
 439         (when (stringp face)
 440           (setq face (make-face (intern (format "liece-quoted-color-%s-%d"
 441                                                 vender num))))
 442           (set-face-foreground face (car faces))
 443           (setcar faces face))
 444         (overlay-put ovl 'face face)))))
 445
 446 (provide 'liece-hilit)
 447
 448 ;;; liece-hilit.el ends here