X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=wl%2Fwl-highlight.el;h=9cbfd2193fed860a1e122dcb97517628b76c0981;hb=709366cf00291239e4287abb0b2105ad47fdbf59;hp=5b5732f683059fe49d72521c7f941025fb628387;hpb=3f2f60a040b29d5e366f8db59c3c582fd1f4f8ee;p=elisp%2Fwanderlust.git diff --git a/wl/wl-highlight.el b/wl/wl-highlight.el index 5b5732f..9cbfd21 100644 --- a/wl/wl-highlight.el +++ b/wl/wl-highlight.el @@ -1,6 +1,6 @@ -;;; wl-highlight.el -- Hilight modules for Wanderlust. +;;; wl-highlight.el --- Hilight modules for Wanderlust. -;; Copyright 1998,1999,2000 Yuuichi Teranishi +;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi ;; Author: Yuuichi Teranishi ;; Keywords: mail, net news @@ -33,16 +33,13 @@ (featurep 'dragdrop)) (require 'wl-dnd)) (require 'wl-vars) -(require 'product) -(product-provide (provide 'wl-highlight) (require 'wl-version)) +(provide 'wl-highlight) ; circular dependency (eval-when-compile (cond (wl-on-xemacs (require 'wl-xmas)) (wl-on-emacs21 (require 'wl-e21)) - (wl-on-nemacs - (require 'wl-nemacs)) (t (require 'wl-mule))) (defun-maybe extent-begin-glyph (a)) @@ -721,43 +718,30 @@ wl-highlight-message-cited-text-9 wl-highlight-message-cited-text-10)) -(defmacro defun-hilit (name &rest everything-else) - "Define a function for highlight. Nemacs implementation is set as empty." - (if wl-on-nemacs - (` (defun (, name) nil nil)) - (` (defun (, name) (,@ everything-else))))) - -(defmacro defun-hilit2 (name &rest everything-else) - "Define a function for highlight w/o nemacs." - (if wl-on-nemacs - () ; noop - (` (defun (, name) (,@ everything-else))))) - (defmacro wl-delete-all-overlays () "Delete all momentary overlays." - (if wl-on-nemacs - nil - '(let ((overlays (overlays-in (point-min) (point-max))) - overlay) - (while (setq overlay (car overlays)) - (if (overlay-get overlay 'wl-momentary-overlay) - (delete-overlay overlay)) - (setq overlays (cdr overlays)))))) - -(defun-hilit wl-highlight-summary-displaying () + '(let ((overlays (overlays-in (point-min) (point-max))) + overlay) + (while (setq overlay (car overlays)) + (if (overlay-get overlay 'wl-momentary-overlay) + (delete-overlay overlay)) + (setq overlays (cdr overlays))))) + +(defun wl-highlight-summary-displaying () (interactive) (wl-delete-all-overlays) (let (bol eol ov) (save-excursion + (end-of-line) + (setq eol (point)) (beginning-of-line) (setq bol (point)) - (save-excursion (end-of-line) (setq eol (point))) (setq ov (make-overlay bol eol)) (overlay-put ov 'face 'wl-highlight-summary-displaying-face) (overlay-put ov 'evaporate t) (overlay-put ov 'wl-momentary-overlay t)))) -(defun-hilit2 wl-highlight-folder-group-line (numbers) +(defun wl-highlight-folder-group-line (numbers) (end-of-line) (let ((eol (point)) bol) @@ -790,17 +774,17 @@ (put-text-property bol (match-end 0) 'face face))) (put-text-property bol eol 'face text-face))))) -(defun-hilit2 wl-highlight-summary-line-string (line mark temp-mark indent) +(defun wl-highlight-summary-line-string (line mark temp-mark indent) (let (fsymbol) (cond ((and (string= temp-mark "+") - (member mark (list wl-summary-unread-cached-mark - wl-summary-unread-uncached-mark - wl-summary-new-mark))) + (member mark (list elmo-msgdb-unread-cached-mark + elmo-msgdb-unread-uncached-mark + elmo-msgdb-new-mark))) (setq fsymbol 'wl-highlight-summary-high-unread-face)) ((and (string= temp-mark "-") - (member mark (list wl-summary-unread-cached-mark - wl-summary-unread-uncached-mark - wl-summary-new-mark))) + (member mark (list elmo-msgdb-unread-cached-mark + elmo-msgdb-unread-uncached-mark + elmo-msgdb-new-mark))) (setq fsymbol 'wl-highlight-summary-low-unread-face)) ((string= temp-mark "o") (setq fsymbol 'wl-highlight-summary-refiled-face)) @@ -810,77 +794,69 @@ (setq fsymbol 'wl-highlight-summary-deleted-face)) ((string= temp-mark "*") (setq fsymbol 'wl-highlight-summary-temp-face)) - ((string= mark wl-summary-new-mark) + ((string= mark elmo-msgdb-new-mark) (setq fsymbol 'wl-highlight-summary-new-face)) - ((member mark (list wl-summary-unread-cached-mark - wl-summary-unread-uncached-mark)) + ((member mark (list elmo-msgdb-unread-cached-mark + elmo-msgdb-unread-uncached-mark)) (setq fsymbol 'wl-highlight-summary-unread-face)) - ((or (string= mark wl-summary-important-mark)) + ((or (string= mark elmo-msgdb-important-mark)) (setq fsymbol 'wl-highlight-summary-important-face)) ((string= temp-mark "-") (setq fsymbol 'wl-highlight-summary-low-read-face)) ((string= temp-mark "+") (setq fsymbol 'wl-highlight-summary-high-read-face)) - (t (if (= 0 (length indent)) + (t (if (zerop (length indent)) (setq fsymbol 'wl-highlight-summary-thread-top-face) (setq fsymbol 'wl-highlight-summary-normal-face)))) (put-text-property 0 (length line) 'face fsymbol line)) (if wl-use-highlight-mouse-line (put-text-property 0 (length line) 'mouse-face 'highlight line))) -(defun-hilit2 wl-highlight-summary-current-line (&optional smark regexp temp-too) +(defun wl-highlight-summary-current-line (&optional smark regexp temp-too) (interactive) (save-excursion (let ((inhibit-read-only t) (case-fold-search nil) temp-mark status-mark - (sregexp (concat - "^" - wl-summary-buffer-number-regexp - "\\(.\\)\\(.\\)../..\(.*\)..:.. \\(" - wl-highlight-thread-indent-string-regexp - "\\)[[<]")) - fregexp fsymbol bol eol matched thread-top looked-at) + (deactivate-mark nil) + fregexp fsymbol bol eol matched thread-top looked-at dest ds) + (end-of-line) + (setq eol (point)) (beginning-of-line) (setq bol (point)) - (save-excursion (end-of-line) (setq eol (point))) (if smark (setq status-mark smark) - (setq looked-at (looking-at sregexp)) - (setq status-mark (buffer-substring (match-beginning 2) - (match-end 2)))) + (setq status-mark (wl-summary-persistent-mark))) (when temp-too - (unless looked-at - (setq looked-at (looking-at sregexp))) - (when looked-at - (setq temp-mark (buffer-substring (match-beginning 1) - (match-end 1))) - (cond - ((string= temp-mark "*") - (setq fsymbol 'wl-highlight-summary-temp-face)) - ((string= temp-mark "D") - (setq fsymbol 'wl-highlight-summary-deleted-face)) - ((string= temp-mark "O") - (setq fsymbol 'wl-highlight-summary-copied-face)) - ((string= temp-mark "o") - (setq fsymbol 'wl-highlight-summary-refiled-face))))) + (setq temp-mark (wl-summary-temp-mark)) + (cond + ((string= temp-mark "*") + (setq fsymbol 'wl-highlight-summary-temp-face)) + ((string= temp-mark "D") + (setq fsymbol 'wl-highlight-summary-deleted-face)) + ((string= temp-mark "O") + (setq fsymbol 'wl-highlight-summary-copied-face + dest t)) + ((string= temp-mark "o") + (setq fsymbol 'wl-highlight-summary-refiled-face + dest t)))) (if (not fsymbol) (cond ((and (string= temp-mark "+") - (member status-mark (list wl-summary-unread-cached-mark - wl-summary-unread-uncached-mark - wl-summary-new-mark))) + (member status-mark (list elmo-msgdb-unread-cached-mark + elmo-msgdb-unread-uncached-mark + elmo-msgdb-new-mark))) (setq fsymbol 'wl-highlight-summary-high-unread-face)) ((and (string= temp-mark "-") - (member status-mark (list wl-summary-unread-cached-mark - wl-summary-unread-uncached-mark - wl-summary-new-mark))) + (member status-mark (list elmo-msgdb-unread-cached-mark + elmo-msgdb-unread-uncached-mark + elmo-msgdb-new-mark))) (setq fsymbol 'wl-highlight-summary-low-unread-face)) - ((string= status-mark wl-summary-new-mark) + ((string= status-mark elmo-msgdb-new-mark) (setq fsymbol 'wl-highlight-summary-new-face)) - ((member status-mark (list wl-summary-unread-cached-mark - wl-summary-unread-uncached-mark)) + ((member status-mark (list elmo-msgdb-unread-cached-mark + elmo-msgdb-unread-uncached-mark)) (setq fsymbol 'wl-highlight-summary-unread-face)) - ((string= status-mark wl-summary-important-mark) + ((string= status-mark elmo-msgdb-important-mark) (setq fsymbol 'wl-highlight-summary-important-face)) ;; score mark ((string= temp-mark "-") @@ -888,13 +864,21 @@ ((string= temp-mark "+") (setq fsymbol 'wl-highlight-summary-high-read-face)) ;; - (t (if (and looked-at - (string= (buffer-substring - (match-beginning 3) - (match-end 3)) "")) + (t (if (null + (wl-thread-entity-get-parent-entity + (wl-thread-get-entity (wl-summary-message-number)))) (setq fsymbol 'wl-highlight-summary-thread-top-face) (setq fsymbol 'wl-highlight-summary-normal-face))))) (put-text-property bol eol 'face fsymbol) + (when dest + (put-text-property (next-single-property-change + (next-single-property-change + bol 'wl-summary-destination + nil eol) + 'wl-summary-destination nil eol) + eol + 'face + 'wl-highlight-refile-destination-face)) (if wl-use-highlight-mouse-line (put-text-property bol ;;; Use bol instead of (1- (match-end 0)) @@ -906,7 +890,7 @@ (if wl-use-dnd (wl-dnd-set-drag-starter bol eol))))) -(defun-hilit2 wl-highlight-folder (start end) +(defun wl-highlight-folder (start end) "Highlight folder between start and end. Faces used: wl-highlight-folder-unknown-face unread messages @@ -936,7 +920,7 @@ Variables used: (wl-highlight-folder-current-line) (forward-line 1))))))) -(defun-hilit2 wl-highlight-folder-path (folder-path) +(defun wl-highlight-folder-path (folder-path) "Highlight current folder path...overlay" (save-excursion (wl-delete-all-overlays) @@ -960,17 +944,17 @@ Variables used: (overlay-put ov 'wl-momentary-overlay t)) (forward-line 1))))) -(defun-hilit2 wl-highlight-refile-destination-string (string) +(defun wl-highlight-refile-destination-string (string) (put-text-property 0 (length string) 'face 'wl-highlight-refile-destination-face string)) -(defun-hilit wl-highlight-summary-all () +(defun wl-highlight-summary-all () "For evaluation" (interactive) (wl-highlight-summary (point-min)(point-max))) -(defun-hilit2 wl-highlight-summary (start end) +(defun wl-highlight-summary (start end &optional lazy) "Highlight summary between start and end. Faces used: wl-highlight-summary-unread-face unread messages @@ -987,38 +971,38 @@ Variables used: wl-highlight-summary-refiled-regexp matches messages mark as refiled wl-highlight-summary-copied-regexp matches messages mark as copied wl-highlight-summary-new-regexp matches new messages - -If HACK-SIG is true,then we search backward from END for something that -looks like the beginning of a signature block, and don't consider that a -part of the message (this is because signatures are often incorrectly -interpreted as cited text.)" +" (if (< end start) (let ((s start)) (setq start end end s))) - (let* ((lines (count-lines start end)) - (too-big (and wl-highlight-max-summary-lines - (> lines wl-highlight-max-summary-lines))) - (real-end end) - gc-message - e p hend i percent) + (let (lines too-big gc-message e p hend i percent) (save-excursion - (save-restriction - (widen) - (narrow-to-region start end) - (if (not too-big) - (save-restriction - (goto-char start) - (setq i 0) - (while (not (eobp)) - (wl-highlight-summary-current-line nil nil wl-summary-scored) - (when (> lines elmo-display-progress-threshold) - (setq i (+ i 1)) - (setq percent (/ (* i 100) lines)) - (if (or (eq (% percent 5) 0) (= i lines)) - (elmo-display-progress - 'wl-highlight-summary "Highlighting..." - percent))) - (forward-line 1)) - (message "Highlighting...done"))))))) + (unless wl-summary-lazy-highlight + (setq lines (count-lines start end) + too-big (and wl-highlight-max-summary-lines + (> lines wl-highlight-max-summary-lines)))) + (goto-char start) + (setq i 0) + (while (and (not (eobp)) + (< (point) end)) + (when (or (not lazy) + (null (get-text-property (point) 'face))) + (wl-highlight-summary-current-line nil nil + (or wl-summary-lazy-highlight + wl-summary-scored))) + (forward-line 1)) + (unless wl-summary-lazy-highlight + (message "Highlighting...done"))))) + +(defun wl-highlight-summary-window (&optional win beg) + "Highlight summary window. +This function is defined for `window-scroll-functions'" + (if wl-summary-highlight + (with-current-buffer (window-buffer win) + (when (eq major-mode 'wl-summary-mode) + (wl-highlight-summary (window-start win) + (window-end win) + 'lazy) + (set-buffer-modified-p nil))))) (defun wl-highlight-headers (&optional for-draft) (let ((beg (point-min)) @@ -1027,47 +1011,21 @@ interpreted as cited text.)" (point-max)))) (wl-highlight-message beg end nil) (unless for-draft - (wl-highlight-message-add-buttons-to-header beg end) - (and wl-highlight-x-face-func - (funcall wl-highlight-x-face-func beg end))) + (when wl-highlight-x-face-function + (funcall wl-highlight-x-face-function))) (run-hooks 'wl-highlight-headers-hook))) -(defun wl-highlight-message-add-buttons-to-header (start end) - (save-excursion - (save-restriction - (narrow-to-region start end) - (let ((case-fold-search t) - (alist wl-highlight-message-header-button-alist) - entry) - (while alist - (setq entry (car alist) - alist (cdr alist)) - (goto-char (point-min)) - (while (re-search-forward (car entry) nil t) - (setq start (match-beginning 0) - end (if (re-search-forward "^[^ \t]" nil t) - (match-beginning 0) - (point-max))) - (goto-char start) - (while (re-search-forward (nth 1 entry) end t) - (goto-char (match-end 0)) - (wl-message-add-button - (match-beginning (nth 2 entry)) - (match-end (nth 2 entry)) - (nth 3 entry) (match-string (nth 4 entry)))) - (goto-char end))))))) - (defun wl-highlight-body-all () (wl-highlight-message (point-min) (point-max) t t)) -(defun-hilit wl-highlight-body () +(defun wl-highlight-body () (let ((beg (or (save-excursion (goto-char (point-min)) (re-search-forward "^$" nil t)) (point-min))) (end (point-max))) (wl-highlight-message beg end t))) -(defun-hilit2 wl-highlight-body-region (beg end) +(defun wl-highlight-body-region (beg end) (wl-highlight-message beg end t t)) (defun wl-highlight-signature-search-simple (beg end) @@ -1110,7 +1068,7 @@ Returns start point of signature." (point))) ;; if no separator found, returns end. ))) -(defun-hilit2 wl-highlight-message (start end hack-sig &optional body-only) +(defun wl-highlight-message (start end hack-sig &optional body-only) "Highlight message headers between start and end. Faces used: wl-highlight-message-headers the part before the colon @@ -1152,9 +1110,10 @@ interpreted as cited text.)" (widen) ;; take off signature (if (and hack-sig (not too-big)) - (setq end (funcall wl-highlight-signature-search-func + (setq end (funcall wl-highlight-signature-search-function (- end wl-max-signature-size) end))) - (if hack-sig + (if (and hack-sig + (not (eq end real-end))) (put-text-property end (point-max) 'face 'wl-highlight-message-signature)) (narrow-to-region start end) @@ -1259,4 +1218,7 @@ interpreted as cited text.)" (inhibit-read-only t)) (put-text-property beg end 'mouse-face 'highlight))) +(require 'product) +(product-provide (provide 'wl-highlight) (require 'wl-version)) + ;;; wl-highlight.el ends here