;;; mew-highlight.el --- Highlight for Mew

;; Author:  Kazu Yamamoto <Kazu@Mew.org>
;; Created: Oct 18, 1997
;; Revised: Oct 25, 1997

;;; Code:

(defconst mew-highlight-version "mew-highlight.el version 0.02")

(require 'mew)

;;
;; functions
;;


(defun mew-summary-highlight-setup ()
  "A function to setup mouse line for Summary and Virtual mode."
  (if (and mew-xemacs-p mew-use-highlight-mouse-line)
      (setq mode-motion-hook mew-highlight-mouse-line-function)))

(defalias 'mew-virtual-highlight-setup 'mew-summary-highlight-setup)

(defun mew-highlight-cursor-line ()
  "A function to highlight the cursor line in Summary and Virtual mode."
  (if mew-use-highlight-cursor-line
      (let ((buffer-read-only nil))
	(if (mew-overlay-p mew-overlay-cursor-line)
	    (mew-overlay-move mew-overlay-cursor-line
			      (save-excursion (beginning-of-line) (point))
			      (save-excursion (end-of-line) (point)))
	  (setq mew-overlay-cursor-line
		(mew-overlay-make
		 (save-excursion (beginning-of-line) (point))
		 (save-excursion (end-of-line) (point))))
	  (mew-overlay-put mew-overlay-cursor-line 'face 
			   mew-highlight-cursor-line-face)
	  ))))

(defun mew-highlight-url ()
  "A function to highlight URL in Message mode."
  (if mew-use-highlight-url
      (let ((url-regex mew-use-highlight-url-regex)
	    (buffer-read-only nil)
	    bound overlay)
	(save-excursion
	  (goto-char (point-min))
	  (setq bound (+ mew-highlight-url-max-size (point)))
	  (while (re-search-forward url-regex bound t)
	    (setq overlay (mew-overlay-make (match-beginning 0) (match-end 0)))
	    (mew-overlay-put overlay 'face mew-highlight-url-face)
	    (mew-overlay-put overlay 'mouse-face mew-highlight-url-mouse-face)
	    )))))

(defun mew-highlight-mark-region (beg end)
  (interactive "r")
  (if (and (or window-system mew-xemacs-p) mew-use-highlight-mark
	   (mew-folder-member (buffer-name) mew-highlight-mark-folder-list))
      (let ((regex (concat mew-summary-message-regex "\\([^ ]\\)"))
	    (buffer-read-only nil) face)
      (save-excursion
	(goto-char beg)
	(while (re-search-forward regex end t)
	  (setq face (cdr (assoc (string-to-char (mew-match 2))
				 mew-highlight-mark-keywords)))
	  (if face
	      (put-text-property
	       (save-excursion (beginning-of-line) (point))
	       (save-excursion (end-of-line) (point))
	       'face face)))))))

(defun mew-highlight-mark-line (mark)
  (if (and (or window-system mew-xemacs-p) mew-use-highlight-mark
	   (mew-folder-member (buffer-name) mew-highlight-mark-folder-list))
      (let ((buffer-read-only nil) face)
	(setq face (cdr (assoc mark mew-highlight-mark-keywords)))
	(if face
	    (put-text-property
	     (save-excursion (beginning-of-line) (point))
	     (save-excursion (end-of-line) (point))
	     'face face)))))

(defun mew-highlight-unmark-line ()
  (if (and (or window-system mew-xemacs-p) mew-use-highlight-mark
	   (mew-folder-member (buffer-name) mew-highlight-mark-folder-list))
      (remove-text-properties 
       (save-excursion (beginning-of-line) (point))
       (save-excursion (end-of-line) (point))
       '(face nil))))

(defun mew-highlight-header-region (rbeg rend)
  "A function to highligh header in Message and Draft mode."
  (interactive "r")
  (if (and (or window-system mew-xemacs-p) mew-use-highlight-header)
      (let ((buffer-read-only nil)
	    key beg med n-spec overlay key-face val-face)
	(save-excursion
	  (save-restriction
	    (narrow-to-region rbeg rend)
	    (goto-char rbeg)
	    (while (not (eobp))
	      (if (not (looking-at mew-keyval))
		  (forward-line)
		(setq key (mew-match 1))
		(setq beg (match-beginning 0))
		(setq med (match-end 0))
		(forward-line)
		(while (looking-at mew-lwsp) (forward-line))
		(setq n-spec (mew-assoc-match3 key mew-field-spec 0))
		(setq key-face (or (nth 3 n-spec) mew-highlight-header-face-key))
		(setq val-face (or (nth 4 n-spec) mew-highlight-header-face-marginal))

		(setq overlay (mew-overlay-make beg med))
		(mew-overlay-put overlay 'face key-face)
		(setq overlay (mew-overlay-make med (point)))
		(mew-overlay-put overlay 'face val-face))))))))

(defun mew-highlight-body ()
  "A function to highligh body in Message mode."
  (if (and (or window-system mew-xemacs-p) mew-use-highlight-body)
      (save-excursion
	(save-restriction
	  (let ((keywords mew-highlight-body-keywords)
		(buffer-read-only nil)
		(line 1)
		beg1 end1 overlay assoc key)
	    (goto-char (point-min))
	    (and (equal mew-message-citation 'header)
		 (re-search-forward "\n-*\n" nil t)
		 (narrow-to-region (point) (point-max)))
	    (while (and (not (eobp)) (< line mew-highlight-body-max-line))
	      (if (looking-at mew-highlight-body-keywords-regex)
		  (progn
		    (setq beg1 (match-beginning 0))
		    (setq end1 (match-end 0))
		    (setq key (mew-match 0))
		    (if (setq assoc (mew-assoc-match2 key keywords 0))
			(progn
			  (setq overlay (mew-overlay-make beg1 end1))
			  (mew-overlay-put overlay 'face (nth 1 assoc))))))
	      (forward-line)
	      (setq line (1+ line))))))))

;;
;; X-Face:
;;

(defun mew-highlight-x-face (beg end)
  "A function to display X-Face."
  (if (and mew-use-highlight-x-face mew-use-highlight-x-face-function)
      (funcall mew-use-highlight-x-face-function beg end)))

(cond
 (mew-xemacs-p
  (autoload 'highlight-headers-x-face-to-pixmap "highlight-headers")
  (defvar mew-use-highlight-x-face-function
    (function (lambda (beg end)
		(interactive)
		(if (and (or window-system mew-xemacs-p)
			 (mew-which mew-prog-uncompface exec-path)
			 mew-use-highlight-x-face)
		    (save-excursion
		      (goto-char beg)
		      (let ((buffer-read-only nil) xface)
			(while (re-search-forward 
				"^X-Face: *\\(.*\\(\n[ \t].*\\)*\\)\n" end t)
			  (mew-overlay-put
			   (mew-overlay-make
			    (match-beginning 0) (match-end 0))
			   'invisible t)
			  (setq xface (highlight-headers-x-face-to-pixmap
				       (match-beginning 1)
				       (match-end 1)))
			  (save-excursion
			    (goto-char beg)
			    (if (re-search-forward "^\\(From:\\).*" end t)
				(set-extent-begin-glyph 
				 (mew-overlay-make (match-end 1)
						   (match-end 1))
				 xface))))))))
	      )))
 (t
  (defvar mew-use-highlight-x-face-function nil
    "*On Text Emacs, this function is called if mew-use-highlight-x-face
is non nil. This is a temporary solution.")
  (if (and mew-use-highlight-x-face
        (mew-which mew-prog-uncompface exec-path)
        (mew-which-el "bitmap" load-path)
        (mew-which-el "mew-xface-mule" load-path))
      (require 'mew-xface-mule))
  )
 )

;;
;; Setup
;;

(defun mew-highlight-face-setup (flist)
  "A function to create faces according to FLIST.
FLIST is a list of face name symbol and its name convention is
'mew-highlight-xxx-face-yyy'. A base face is copied from
'mew-highlight-xxx-style-yyy' then a color is set from
'mew-highlight-xxx-color-yyy'."
  (if (or window-system mew-xemacs-p)
      (let (fname str style color)
	(while flist
	  (setq fname (car flist))
	  (setq flist (cdr flist))
	  (set fname fname)
	  (setq str (symbol-name fname))
	  (string-match "^\\(mew-highlight-.*-\\)face\\(-.*\\)$" str)
	  (setq style (intern-soft
		       (concat (mew-match 1 str) "style" (mew-match 2 str))))
	  (setq color (intern-soft
		       (concat (mew-match 1 str) "color" (mew-match 2 str))))
	  (copy-face (symbol-value style) fname)
	  (set-face-foreground fname (symbol-value color))))))

(mew-highlight-face-setup mew-highlight-header-face-list)
(mew-highlight-face-setup mew-highlight-body-face-list)
(mew-highlight-face-setup mew-highlight-mark-face-list)

(defun mew-highlight-make-keywords-regex ()
  (setq mew-highlight-body-keywords-regex
	(mapconcat 'identity (mapcar 'car mew-highlight-body-keywords) "\\|"))
  )

(mew-highlight-make-keywords-regex)

(provide 'mew-highlight)

;;; Copyright Notice:

;; Copyright (C) 1997, 1998 Mew developing team.
;; All rights reserved.

;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 3. All advertising materials mentioning features or use of this software
;;    must display the following acknowledgement:
;;       This product includes software developed by 
;;       Mew developing team and its contributors.
;; 4. Neither the name of the team nor the names of its contributors
;;    may be used to endorse or promote products derived from this software
;;    without specific prior written permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; mew-highlight.el ends here
