* 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 (file)
--- a/wl/ChangeLog
+++ b/wl/ChangeLog
@@ -1,5 +1,28 @@
 2003-09-18  Yuuichi Teranishi  <teranisi@gohome.org>
 
+       * 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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)