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 (defadvice font-lock-mode
 349   (around liece-replace-space-in-buffer-name activate)
 350   (if (char-equal (aref (buffer-name) 0) ? )
 351       (unwind-protect
 352           (progn
 353             (aset (buffer-name) 0 ?_)
 354             ad-do-it)
 355         (aset (buffer-name) 0 ? ))
 356     ad-do-it))
 357
 358 (add-hook 'liece-after-load-startup-hook
 359           'liece-highlight-maybe-turn-on-font-lock)
 360
 361 (defun liece-highlight-maybe-turn-on-font-lock ()
 362   (when liece-highlight-mode
 363     (add-hook 'liece-channel-mode-hook
 364               'liece-highlight-turn-on-font-lock)
 365     (add-hook 'liece-others-mode-hook
 366               'liece-highlight-turn-on-font-lock)
 367     (add-hook 'liece-dialogue-mode-hook
 368               'liece-highlight-turn-on-font-lock)
 369     (add-hook 'liece-insert-hook 'liece-url-add-buttons)
 370     (add-hook 'liece-insert-hook 'liece-channel-add-buttons)
 371     ;;(add-hook 'liece-insert-hook 'liece-nick-add-buttons)
 372     ))
 373
 374 (defun liece-highlight-turn-on-font-lock ()
 375   (make-local-variable 'font-lock-defaults)
 376   (setq font-lock-defaults '(liece-highlight-font-lock-keywords t))
 377   (make-local-variable 'font-lock-verbose)
 378   (setq font-lock-verbose nil)
 379   (make-local-variable 'font-lock-support-mode)
 380   (setq font-lock-support-mode nil)
 381   (make-local-hook 'font-lock-mode-hook)
 382   (setq font-lock-mode-hook nil)
 383   (turn-on-font-lock)
 384   (make-local-hook 'after-change-functions)
 385   (or liece-display-prefix-tag
 386       (add-hook 'after-change-functions
 387                 'liece-highlight-maybe-hide-prefix nil 'local))
 388   (add-hook 'after-change-functions
 389             'liece-highlight-colorize-quote nil 'local)
 390   (add-hook 'after-change-functions
 391             'liece-highlight-maybe-hide-quote 'append 'local)
 392   (when (and (eq major-mode 'liece-dialogue-mode)
 393              (liece-functionp liece-highlight-jingle-function))
 394     (add-hook 'after-change-functions
 395               'liece-highlight-maybe-play-jingle 'append 'local)))
 396
 397 (defun liece-highlight-maybe-hide-prefix (st nd len)
 398   (save-excursion
 399     (goto-char st)
 400     (if (looking-at liece-generic-prefix-tag-regexp)
 401         (invisible-region
 402          (match-beginning 1) (match-end 1)))))
 403
 404 (defun liece-highlight-maybe-hide-quote (st nd len)
 405   (save-excursion
 406     (goto-char st)
 407     (while (re-search-forward "[\002\026\037]\\|[\003\013][0-9:;<=]+" nd t)
 408       (invisible-region
 409        (match-beginning 0) (match-end 0)))))
 410
 411 (defun liece-highlight-maybe-play-jingle (st nd len)
 412   (save-excursion
 413     (goto-char st)
 414     (when (re-search-forward
 415            (if (listp liece-highlight-pattern)
 416                (car liece-highlight-pattern)
 417              liece-highlight-pattern)
 418            nd t)
 419       (funcall liece-highlight-jingle-function))))
 420
 421 (defun liece-highlight-colorize-quote (st nd len)
 422   (save-excursion
 423     (goto-char st)
 424     (let (num face faces vender name ovl)
 425       (while (re-search-forward "\\([\003\013][0-9:;<=]+\\)\\([^\002\026\037\003\013]*\\)" nd t)
 426         (setq ovl (make-overlay (match-beginning 2) (match-end 2))
 427               num (match-string 1)
 428               vender (cond ((eq ?\003 (aref num 0)) 'ircle)
 429                            ((eq ?\013 (aref num 0)) 'mirc))
 430               num (if (< 57 (char-int (aref num 1)))
 431                       (- (char-int (aref num 1)) 43)
 432                     (string-to-int (substring num 1)))
 433               faces (nthcdr num (symbol-value
 434                                  (intern (format "liece-quoted-colors-%s"
 435                                                  vender))))
 436               face (car faces))
 437         (when (stringp face)
 438           (setq face (make-face (intern (format "liece-quoted-color-%s-%d"
 439                                                 vender num))))
 440           (set-face-foreground face (car faces))
 441           (setcar faces face))
 442         (overlay-put ovl 'face face)))))
 443
 444 (provide 'liece-hilit)
 445
 446 ;;; liece-hilit.el ends here