X-Git-Url: http://cgit.sxemacs.org/?p=riece;a=blobdiff_plain;f=lisp%2Friece-highlight.el;h=305774766a65a3fff30ac6d22482a48183b7c80e;hp=3c3536d607aa1d025f7ea8517fa7f02c85ae23b7;hb=bc34a63003955546c07a672ffedba63935817011;hpb=649b6a4c8289a91740240b00baaebb673bbcc57b diff --git a/lisp/riece-highlight.el b/lisp/riece-highlight.el index 3c3536d..3057747 100644 --- a/lisp/riece-highlight.el +++ b/lisp/riece-highlight.el @@ -1,4 +1,4 @@ -;;; riece-highlight.el --- coloring IRC buffers +;;; riece-highlight.el --- highlight IRC buffers ;; Copyright (C) 1998-2003 Daiki Ueno ;; Author: Daiki Ueno @@ -19,64 +19,35 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Code: +;;; Commentary: + +;; NOTE: This is an add-on module for Riece. -(eval-when-compile (require 'riece-inlines)) +;;; Code: (require 'riece-globals) +(require 'riece-options) ;riece-channel-list-buffer-mode +(require 'riece-identity) ;riece-format-identity +(require 'riece-misc) (require 'font-lock) +(require 'derived) (defgroup riece-highlight nil - "Highlight your IRC buffer" + "Decorate IRC buffers with faces and fonts." :tag "Highlight" :prefix "riece-" :group 'riece) (defgroup riece-highlight-faces nil - "Faces for highlight your IRC buffer" + "Faces for highlight IRC buffers." :tag "Faces" :prefix "riece-highlight-" :group 'riece-highlight) -(defcustom riece-change-face 'riece-change-face - "Face used for displaying \"*** Change:\" line." - :type 'face - :group 'riece-highlight-faces) - -(defcustom riece-notice-face 'riece-notice-face - "Face used for displaying \"*** Notice:\" line." - :type 'face - :group 'riece-highlight-faces) - -(defcustom riece-wallops-face 'riece-wallops-face - "Face used for displaying \"*** Wallops:\" line." - :type 'face - :group 'riece-highlight-faces) - -(defcustom riece-error-face 'riece-error-face - "Face used for displaying \"*** Error:\" line." - :type 'face - :group 'riece-highlight-faces) - -(defcustom riece-info-face 'riece-info-face - "Face used for displaying \"*** Info:\" line." - :type 'face - :group 'riece-highlight-faces) - -(defcustom riece-server-face 'riece-server-face - "Face used for displaying \"(from server)\" extent." - :type 'face - :group 'riece-highlight-faces) - -(defcustom riece-prefix-face 'riece-prefix-face - "Face used for displaying \"\" extent." - :type 'face - :group 'riece-highlight-faces) - -(defface riece-change-face +(defface riece-dialogue-change-face '((((class color) (background dark)) (:foreground "cyan" :bold t)) @@ -87,8 +58,9 @@ (:bold t))) "Face used for displaying \"*** Change:\" line" :group 'riece-highlight-faces) +(defvar riece-dialogue-change-face 'riece-dialogue-change-face) -(defface riece-notice-face +(defface riece-dialogue-notice-face '((((class color) (background dark)) (:foreground "green2" :bold t)) @@ -99,8 +71,9 @@ (:bold t))) "Face used for displaying \"*** Notice:\" line" :group 'riece-highlight-faces) +(defvar riece-dialogue-notice-face 'riece-dialogue-notice-face) -(defface riece-wallops-face +(defface riece-dialogue-wallops-face '((((class color) (background dark)) (:foreground "yellow" :bold t)) @@ -111,8 +84,9 @@ (:bold t))) "Face used for displaying \"*** Wallops:\" line" :group 'riece-highlight-faces) +(defvar riece-dialogue-wallops-face 'riece-dialogue-wallops-face) -(defface riece-error-face +(defface riece-dialogue-error-face '((((class color) (background dark)) (:foreground "cornflower blue" :bold t)) @@ -123,8 +97,9 @@ (:bold t))) "Face used for displaying \"*** Error:\" line" :group 'riece-highlight-faces) +(defvar riece-dialogue-error-face 'riece-dialogue-error-face) -(defface riece-info-face +(defface riece-dialogue-info-face '((((class color) (background dark)) (:foreground "PaleTurquoise" :bold t)) @@ -135,8 +110,9 @@ (:bold t))) "Face used for displaying \"*** Info:\" line" :group 'riece-highlight-faces) +(defvar riece-dialogue-info-face 'riece-dialogue-info-face) -(defface riece-server-face +(defface riece-dialogue-server-face '((((class color) (background dark)) (:foreground "Gray70")) @@ -147,8 +123,9 @@ (:bold t))) "Face used for displaying \"(from server)\" extent." :group 'riece-highlight-faces) +(defvar riece-dialogue-server-face 'riece-dialogue-server-face) -(defface riece-prefix-face +(defface riece-dialogue-prefix-face '((((class color) (background dark)) (:foreground "moccasin")) @@ -159,12 +136,13 @@ (:bold nil))) "Face used for displaying \"\" extent" :group 'riece-highlight-faces) +(defvar riece-dialogue-prefix-face 'riece-dialogue-prefix-face) -(defcustom riece-highlight-font-lock-keywords +(defcustom riece-dialogue-font-lock-keywords (append (list (list (concat "^" riece-time-prefix-regexp "\\(<[^>]+>\\|>[^<]+<\\|([^)]+)\\|{[^}]+}\\|=[^=]+=\\)") - '(1 riece-prefix-face append t))) + '(1 riece-dialogue-prefix-face append t))) ;; set property to the whole line (mapcar (lambda (line) @@ -174,36 +152,82 @@ (regexp-quote (symbol-value (intern (format "riece-%s-prefix" line)))) ".*\\)$") - (list 1 (intern (format "riece-%s-face" line)) t t))) + (list 1 (intern (format "riece-dialogue-%s-face" line)) t t))) '(change notice wallops error info)) - (list (list "(from [^)]+)$" 0 riece-server-face t))) - "Normal and deformed faces for IRC normal line." + '((riece-highlight-server-match 0 riece-dialogue-server-face t))) + "Default expressions to highlight in riece-dialogue-mode." :type '(repeat (list string)) :group 'riece-highlight) -(defun riece-highlight-schedule-turn-on-font-lock () - (add-hook 'riece-channel-mode-hook - 'riece-highlight-turn-on-font-lock) - (add-hook 'riece-others-mode-hook - 'riece-highlight-turn-on-font-lock) - (add-hook 'riece-dialogue-mode-hook - 'riece-highlight-turn-on-font-lock)) +(defface riece-channel-list-default-face + '((t ())) + "Face used for displaying channels." + :group 'riece-highlight-faces) +(defvar riece-channel-list-default-face 'riece-channel-list-default-face) + +(defface riece-channel-list-current-face + '((((class color) + (background dark)) + (:foreground "turquoise" :underline t)) + (((class color) + (background light)) + (:foreground "SeaGreen" :underline t)) + (t + ())) + "Face used for displaying the current channel." + :group 'riece-highlight-faces) +(defvar riece-channel-list-current-face 'riece-channel-list-current-face) + +(defcustom riece-channel-list-mark-face-alist + '((?* . riece-channel-list-current-face)) + "An alist mapping marks on riece-channel-list-buffer to faces." + :type 'list + :group 'riece-highlight) + +(defcustom riece-channel-list-font-lock-keywords + '(("^[ 0-9][0-9]:\\(.\\)\\(.*\\)" + (2 (or (cdr (assq (aref (match-string 1) 0) + riece-channel-list-mark-face-alist)) + riece-channel-list-default-face)))) + "Default expressions to highlight in riece-channel-list-mode." + :type '(repeat (list string)) + :group 'riece-highlight) + +(unless (riece-facep 'riece-modeline-current-face) + (make-face 'riece-modeline-current-face + "Face used for displaying the current channel in modeline.") + (if (featurep 'xemacs) + (set-face-parent 'riece-modeline-current-face 'modeline)) + (set-face-foreground 'riece-modeline-current-face + (face-foreground 'riece-channel-list-current-face))) -(defvar font-lock-support-mode) -(defun riece-highlight-turn-on-font-lock () +(defconst riece-highlight-description + "Highlight IRC buffers.") + +(defun riece-highlight-server-match (limit) + (and (re-search-forward "(from [^)]+)$" limit t) + (get-text-property (match-beginning 0) 'riece-server-name))) + +(defun riece-highlight-setup-dialogue () (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(riece-highlight-font-lock-keywords t)) - (make-local-variable 'font-lock-verbose) - (setq font-lock-verbose nil) - (when (boundp 'font-lock-support-mode) - (make-local-variable 'font-lock-support-mode) - (setq font-lock-support-mode nil)) - (make-local-hook 'font-lock-mode-hook) - (setq font-lock-mode-hook nil) - (turn-on-font-lock) + (setq font-lock-defaults '(riece-dialogue-font-lock-keywords t)) + ;; In XEmacs, auto-initialization of font-lock is not affective + ;; when buffer-file-name is not set. + (font-lock-set-defaults) (make-local-hook 'after-change-functions) (add-hook 'after-change-functions - 'riece-highlight-hide-prefix nil 'local)) + 'riece-highlight-hide-prefix nil t) + (if (get 'riece-highlight 'riece-addon-enabled) + (font-lock-mode 1))) + +(defun riece-highlight-setup-channel-list () + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults '(riece-channel-list-font-lock-keywords t)) + ;; In XEmacs, auto-initialization of font-lock is not affective + ;; when buffer-file-name is not set. + (font-lock-set-defaults) + (if (get 'riece-highlight 'riece-addon-enabled) + (font-lock-mode 1))) (defun riece-highlight-hide-prefix (start end length) (save-excursion @@ -211,15 +235,92 @@ (if (looking-at riece-prefix-regexp) (put-text-property (match-beginning 1) (match-end 1) 'invisible t)))) +(defun riece-highlight-put-overlay-faces (start end) + (if (get 'riece-highlight 'riece-addon-enabled) + (riece-scan-property-region + 'riece-overlay-face + start end + (lambda (start end) + (riece-overlay-put (riece-make-overlay start end) + 'face + (get-text-property start 'riece-overlay-face)))))) + +(defun riece-highlight-format-identity-for-channel-list-indicator (index + identity) + (if (and (get 'riece-highlight 'riece-addon-enabled) + (riece-identity-equal identity riece-current-channel)) + (let ((string (riece-format-identity identity)) + (start 0)) + ;; Escape % -> %%. + (while (string-match "%" string start) + (setq start (1+ (match-end 0)) + string (replace-match "%%" nil nil string))) + (list (format "%d:" index) + (riece-propertize-modeline-string + string 'face 'riece-modeline-current-face))))) + (defun riece-highlight-insinuate () (put 'riece-channel-mode 'font-lock-defaults - '(riece-highlight-font-lock-keywords t)) + '(riece-dialogue-font-lock-keywords t)) (put 'riece-others-mode 'font-lock-defaults - '(riece-highlight-font-lock-keywords t)) + '(riece-dialogue-font-lock-keywords t)) (put 'riece-dialogue-mode 'font-lock-defaults - '(riece-highlight-font-lock-keywords t)) - (add-hook 'riece-after-load-startup-hook - 'riece-highlight-schedule-turn-on-font-lock)) + '(riece-dialogue-font-lock-keywords t)) + (add-hook 'riece-dialogue-mode-hook + 'riece-highlight-setup-dialogue) + (put 'riece-channel-list-mode 'font-lock-defaults + '(riece-channel-list-font-lock-keywords t)) + (add-hook 'riece-channel-list-mode-hook + 'riece-highlight-setup-channel-list) + (add-hook 'riece-format-identity-for-channel-list-indicator-functions + 'riece-highlight-format-identity-for-channel-list-indicator) + (add-hook 'riece-after-insert-functions + 'riece-highlight-put-overlay-faces)) + +(defun riece-highlight-uninstall () + (let ((buffers riece-buffer-list)) + (save-excursion + (while buffers + (set-buffer (car buffers)) + (if (eq (derived-mode-class major-mode) + 'riece-dialogue-mode) + (remove-hook 'after-change-functions + 'riece-highlight-hide-prefix t)) + (setq buffers (cdr buffers))))) + (riece-remprop 'riece-channel-mode 'font-lock-defaults) + (riece-remprop 'riece-others-mode 'font-lock-defaults) + (riece-remprop 'riece-dialogue-mode 'font-lock-defaults) + (remove-hook 'riece-dialogue-mode-hook + 'riece-highlight-setup-dialogue) + (riece-remprop 'riece-channel-list-mode 'font-lock-defaults) + (remove-hook 'riece-channel-list-mode-hook + 'riece-highlight-setup-channel-list) + (remove-hook 'riece-format-identity-for-channel-list-indicator-functions + 'riece-highlight-format-identity-for-channel-list-indicator) + (remove-hook 'riece-after-insert-functions + 'riece-highlight-put-overlay-faces)) + +(defun riece-highlight-enable () + (let ((buffers riece-buffer-list)) + (while buffers + (if (memq (derived-mode-class + (with-current-buffer (car buffers) + major-mode)) + '(riece-dialogue-mode riece-channel-list-mode)) + (with-current-buffer (car buffers) + (font-lock-mode 1))) + (setq buffers (cdr buffers))))) + +(defun riece-highlight-disable () + (let ((buffers riece-buffer-list)) + (while buffers + (if (memq (derived-mode-class + (with-current-buffer (car buffers) + major-mode)) + '(riece-dialogue-mode riece-channel-list-mode)) + (with-current-buffer (car buffers) + (font-lock-mode 0))) + (setq buffers (cdr buffers))))) (provide 'riece-highlight)