From: teranisi Date: Thu, 18 Sep 2003 11:09:38 +0000 (+0000) Subject: * wl-vars.el (wl-message-use-header-narrowing): New user option. X-Git-Tag: wl-2_11_15~4 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=3fd3d98fb79b66793807556b08203112073afda1;p=elisp%2Fwanderlust.git * wl-vars.el (wl-message-use-header-narrowing): New user option. (wl-message-header-narrowing-fields): Ditto. (wl-message-header-narrowing-lines): Ditto. (wl-message-header-narrowing-string): Ditto. * wl-summary.el (wl-summary-mode-map): Bind wl-summary-toggle-header-narrowing to "C-cC-f". (wl-summary-toggle-header-narrowing): New function. * wl-message.el (wl-message-buffer-create): Call wl-message-header-narrowing-setup. (wl-message-redisplay): Call wl-message-header-narrowing. (wl-message-header-narrowing): New function. (wl-message-header-narrowing-map): New keymap. (wl-message-header-narrowing-widen-map): New keymap. (wl-message-header-narrowing-again-at-mouse): New function. (wl-message-header-narrowing-1): Ditto. (wl-message-header-narrowing-widen-at-mouse): Ditto. (wl-message-header-narrowing-setup): Ditto. (wl-message-header-narrowing-toggle): Ditto. * wl-highlight.el (wl-message-header-narrowing-face): New face. --- diff --git a/wl/ChangeLog b/wl/ChangeLog index 76a5166..e95a217 100644 --- a/wl/ChangeLog +++ b/wl/ChangeLog @@ -1,5 +1,28 @@ 2003-09-18 Yuuichi Teranishi + * wl-vars.el (wl-message-use-header-narrowing): New user option. + (wl-message-header-narrowing-fields): Ditto. + (wl-message-header-narrowing-lines): Ditto. + (wl-message-header-narrowing-string): Ditto. + + * wl-summary.el (wl-summary-mode-map): Bind + wl-summary-toggle-header-narrowing to "C-cC-f". + (wl-summary-toggle-header-narrowing): New function. + + * wl-message.el (wl-message-buffer-create): Call + wl-message-header-narrowing-setup. + (wl-message-redisplay): Call wl-message-header-narrowing. + (wl-message-header-narrowing): New function. + (wl-message-header-narrowing-map): New keymap. + (wl-message-header-narrowing-widen-map): New keymap. + (wl-message-header-narrowing-again-at-mouse): New function. + (wl-message-header-narrowing-1): Ditto. + (wl-message-header-narrowing-widen-at-mouse): Ditto. + (wl-message-header-narrowing-setup): Ditto. + (wl-message-header-narrowing-toggle): Ditto. + + * wl-highlight.el (wl-message-header-narrowing-face): New face. + * wl-vars.el (wl-folder-sync-range-alist): Set default range for 'flag as all. (wl-use-flag-folder-help-echo): New user option. diff --git a/wl/wl-highlight.el b/wl/wl-highlight.el index b432a6a..4c501fb 100644 --- a/wl/wl-highlight.el +++ b/wl/wl-highlight.el @@ -748,6 +748,16 @@ :group 'wl-message-faces :group 'wl-faces) +(defface wl-message-header-narrowing-face + '((((class color) (background light)) + (:foreground "black" :background "dark khaki")) + (((class color) (background dark)) + (:foreground "white" :background "dark goldenrod")) + (t (:bold t))) + "Face used for header narrowing for the message." + :group 'wl-message-faces + :group 'wl-faces) + (defvar wl-highlight-folder-opened-regexp " *\\(\\[\\-\\]\\)") (defvar wl-highlight-folder-closed-regexp " *\\(\\[\\+\\]\\)") (defvar wl-highlight-folder-leaf-regexp "[ ]*\\([-%\\+]\\)\\(.*\\):.*$") diff --git a/wl/wl-message.el b/wl/wl-message.el index ba7d3c6..e52b7b0 100644 --- a/wl/wl-message.el +++ b/wl/wl-message.el @@ -137,6 +137,8 @@ If original message buffer already exists, it is re-used." (with-current-buffer buffer (setq wl-message-buffer-original-buffer (wl-original-message-buffer-get name)) + (when wl-message-use-header-narrowing + (wl-message-header-narrowing-setup)) (run-hooks 'wl-message-buffer-created-hook)) buffer)) @@ -454,6 +456,8 @@ Returns non-nil if bottom of message." (when (re-search-forward "^$" nil t) (wl-message-add-buttons-to-header (point-min) (point)) (wl-message-add-buttons-to-body (point) (point-max))) + (when wl-message-use-header-narrowing + (wl-message-header-narrowing)) (goto-char (point-min)) (ignore-errors (run-hooks 'wl-message-redisplay-hook)) ;; go back to summary mode @@ -760,6 +764,122 @@ Returns non-nil if bottom of message." (set-buffer buf) filename)))) +;;; Header narrowing courtesy of Hideyuki Shirai. +(defun wl-message-header-narrowing () + "Narrowing headers." + (unless (eq this-command 'wl-summary-redisplay-all-header) + (save-excursion + (save-restriction + (goto-char (point-min)) + (if (re-search-forward "^$" nil t) + (beginning-of-line) + (goto-char (point-max))) + (narrow-to-region (point-min) (point)) + (let ((fields wl-message-header-narrowing-fields)) + (while fields + (wl-message-header-narrowing-1 (concat "^" (car fields) ":")) + (setq fields (cdr fields)))))))) + +(defvar wl-message-header-narrowing-map (make-sparse-keymap)) +(define-key wl-message-header-narrowing-map [mouse-2] + 'wl-message-header-narrowing-again-at-mouse) + +(defvar wl-message-header-narrowing-widen-map (make-sparse-keymap)) +(define-key wl-message-header-narrowing-widen-map [mouse-2] + 'wl-message-header-narrowing-widen-at-mouse) + +(defun wl-message-header-narrowing-again-at-mouse (event) + (interactive "e") + (save-window-excursion + (save-excursion + (mouse-set-point event) + (wl-message-header-narrowing)))) + +(defun wl-message-header-narrowing-1 (hregexp) + (let ((case-fold-search t) + ov start end) + (goto-char (point-min)) + (while (re-search-forward hregexp nil t) + (setq start (match-beginning 0)) + (forward-line 1) + (setq end (progn (while (looking-at "^[ \t]") (forward-line)) + (forward-line -1) + (line-end-position))) + (if (<= (count-lines start end) wl-message-header-narrowing-lines) + (forward-line 1) + (goto-char start) + (forward-line (1- wl-message-header-narrowing-lines)) + (end-of-line) + (setq start (point)) + (unless (eq (get-char-property start 'invisible) + 'wl-message-header-narrowing) + (setq ov (or + (let ((ovs (overlays-at start)) + ov) + (while (and ovs (not (overlayp ov))) + (if (overlay-get (car ovs) + 'wl-message-header-narrowing) + (setq ov (car ovs))) + (setq ovs (cdr ovs))) + ov) + (make-overlay start end))) + (overlay-put ov 'wl-message-header-narrowing t) + (overlay-put ov 'evaporate t) + (overlay-put ov 'invisible 'wl-message-header-narrowing) + (overlay-put ov 'after-string + wl-message-header-narrowing-string)))))) + +(defun wl-message-header-narrowing-widen-at-mouse (event) + (interactive "e") + (save-selected-window + (select-window (posn-window (event-start event))) + (let* ((win (selected-window)) + (wpos (window-start win)) + (pos (posn-point (event-start event))) + (ovs (overlays-in (1- pos) (1+ pos))) ;; Uum... + ov) + (while (and ovs (not (overlayp ov))) + (when (overlay-get (car ovs) 'wl-message-header-narrowing) + (setq ov (car ovs))) + (setq ovs (cdr ovs))) + (when (overlayp ov) + (overlay-put ov 'face 'wl-message-header-narrowing-face) + (overlay-put ov 'local-map wl-message-header-narrowing-map) + (overlay-put ov 'invisible nil) + (overlay-put ov 'after-string nil)) + (set-window-start win wpos)))) + +(defun wl-message-header-narrowing-setup () + (when (boundp 'line-move-ignore-invisible) + (set (make-local-variable 'line-move-ignore-invisible) t)) + (set-text-properties 0 (length wl-message-header-narrowing-string) + `(face + wl-message-header-narrowing-face + keymap + ,wl-message-header-narrowing-widen-map) + wl-message-header-narrowing-string)) + +(defun wl-message-header-narrowing-toggle () + "Toggle header narrowing." + (interactive) + (when wl-message-use-header-narrowing + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "^$" nil t) + (beginning-of-line) + (goto-char (point-max))) + (let ((ovs (overlays-in (point-min) (point))) + ov hn-ovs) + (while (setq ov (car ovs)) + (when (overlay-get ov 'wl-message-header-narrowing) + (setq hn-ovs (cons ov hn-ovs))) + (setq ovs (cdr ovs))) + (if hn-ovs + (while hn-ovs + (delete-overlay (car hn-ovs)) + (setq hn-ovs (cdr hn-ovs))) + (wl-message-header-narrowing)))))) + (require 'product) (product-provide (provide 'wl-message) (require 'wl-version)) diff --git a/wl/wl-summary.el b/wl/wl-summary.el index f38da63..12f9523 100644 --- a/wl/wl-summary.el +++ b/wl/wl-summary.el @@ -533,6 +533,8 @@ See also variable `wl-use-petname'." (define-key wl-summary-mode-map "hm" 'wl-score-set-mark-below) (define-key wl-summary-mode-map "hx" 'wl-score-set-expunge-below) + ;; misc + (define-key wl-summary-mode-map "\C-c\C-f" 'wl-summary-toggle-header-narrowing) (define-key wl-summary-mode-map "\M-t" 'wl-toggle-plugged) (define-key wl-summary-mode-map "\C-t" 'wl-plugged-change) ;; @@ -4590,6 +4592,20 @@ If ASK-CODING is non-nil, coding-system for the message is asked." (setq wl-summary-buffer-saved-message nil))) (message "There's no saved message."))) +(defun wl-summary-toggle-header-narrowing () + "Toggle message header narrowing." + (interactive) + (when wl-message-use-header-narrowing + (save-selected-window + (let* ((mbuf wl-message-buffer) + (mwin (when mbuf (get-buffer-window mbuf))) + (wpos (when mwin (window-start mwin)))) + (when mbuf + (set-buffer mbuf) + (wl-message-header-narrowing-toggle) + (and wpos (set-window-start mwin wpos))))))) + + (require 'product) (product-provide (provide 'wl-summary) (require 'wl-version)) diff --git a/wl/wl-vars.el b/wl/wl-vars.el index 2ec2e0c..8380cd2 100644 --- a/wl/wl-vars.el +++ b/wl/wl-vars.el @@ -1518,6 +1518,26 @@ which appear just before @." :type 'boolean :group 'wl-pref) +(defcustom wl-message-use-header-narrowing t + "Use header narrowing when non-nil." + :type 'boolean + :group 'wl-pref) + +(defcustom wl-message-header-narrowing-fields '("to" "cc") + "A list of field name to enable header narrowing." + :type '(repeat string) + :group 'wl-pref) + +(defcustom wl-message-header-narrowing-lines 4 + "Line number to enable the header narrowing." + :type 'integer + :group 'wl-pref) + +(defcustom wl-message-header-narrowing-string "..." + "A string used for header narrowing truncation." + :type 'string + :group 'wl-pref) + (defvar wl-message-mode-line-format-spec-alist '((?f (if (memq 'modeline wl-use-folder-petname) (wl-folder-get-petname wl-message-buffer-cur-folder)