(defvar wl-message-buffer nil) ; message buffer.
-(defvar wl-message-buffer-cur-summary-buffer nil)
(defvar wl-message-buffer-cur-folder nil)
(defvar wl-message-buffer-cur-number nil)
(defvar wl-message-buffer-cur-flag nil)
(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))
"Scroll down current message by LINES.
Returns non-nil if top of message."
(interactive)
- (let (cur-buf top real-top)
- (unless (eq major-mode 'mime-view-mode)
- (when (buffer-live-p wl-message-buffer)
- (setq cur-buf (current-buffer))
- (wl-message-select-buffer wl-message-buffer)))
- (move-to-window-line 0)
- (if (and wl-break-pages
- (bobp)
- (not (setq real-top (save-restriction (widen) (bobp)))))
- (progn
- (wl-message-narrow-to-page -1)
- (goto-char (point-max))
- (recenter))
- (if (not (bobp))
- (condition-case nil
- (scroll-down (or lines wl-message-scroll-amount))
- (error))
- (setq top t)))
- (if real-top
- (let ((f (assq (mime-preview-original-major-mode)
- mime-preview-over-to-previous-method-alist)))
- (if f (funcall (cdr f))))
- (when cur-buf
- (select-window (get-buffer-window cur-buf))))
+ (let (top real-top)
+ (save-selected-window
+ (unless (eq major-mode 'mime-view-mode)
+ (when (buffer-live-p wl-message-buffer)
+ (wl-message-select-buffer wl-message-buffer)))
+ (move-to-window-line 0)
+ (if (and wl-break-pages
+ (bobp)
+ (not (setq real-top (save-restriction (widen) (bobp)))))
+ (progn
+ (wl-message-narrow-to-page -1)
+ (goto-char (point-max))
+ (recenter))
+ (if (not (bobp))
+ (condition-case nil
+ (scroll-down (or lines wl-message-scroll-amount))
+ (error))
+ (setq top t)))
+ (if real-top
+ (let ((f (assq (mime-preview-original-major-mode)
+ mime-preview-over-to-previous-method-alist)))
+ (if f (funcall (cdr f))))))
top))
(defun wl-message-next-page (&optional lines)
"Scroll up current message by LINES.
Returns non-nil if bottom of message."
(interactive)
- (let (cur-buf bottom)
- (unless (eq major-mode 'mime-view-mode)
- (when (buffer-live-p wl-message-buffer)
- (setq cur-buf (current-buffer))
- (wl-message-select-buffer wl-message-buffer)))
- (move-to-window-line -1)
- (if (save-excursion
- (end-of-line)
- (and (pos-visible-in-window-p)
- (eobp)))
- (if (or (null wl-break-pages)
- (save-excursion
- (save-restriction
- (widen) (forward-line) (eobp))))
- (setq bottom t)
- (wl-message-narrow-to-page 1)
- (setq bottom nil))
- (condition-case ()
- (static-if (boundp 'window-pixel-scroll-increment)
- ;; XEmacs 21.2.20 and later.
- (let (window-pixel-scroll-increment)
- (scroll-up (or lines wl-message-scroll-amount)))
- (scroll-up (or lines wl-message-scroll-amount)))
- (end-of-buffer
- (goto-char (point-max))))
- (setq bottom nil))
- (if (eobp)
- (let ((f (assq (mime-preview-original-major-mode)
- mime-preview-over-to-next-method-alist)))
- (if f (funcall (cdr f))))
- (when cur-buf
- (select-window (get-buffer-window cur-buf))))
+ (let (bottom)
+ (save-selected-window
+ (unless (eq major-mode 'mime-view-mode)
+ (when (buffer-live-p wl-message-buffer)
+ (wl-message-select-buffer wl-message-buffer)))
+ (move-to-window-line -1)
+ (if (save-excursion
+ (end-of-line)
+ (and (pos-visible-in-window-p)
+ (eobp)))
+ (if (or (null wl-break-pages)
+ (save-excursion
+ (save-restriction
+ (widen) (forward-line) (eobp))))
+ (setq bottom t)
+ (wl-message-narrow-to-page 1)
+ (setq bottom nil))
+ (condition-case ()
+ (static-if (boundp 'window-pixel-scroll-increment)
+ ;; XEmacs 21.2.20 and later.
+ (let (window-pixel-scroll-increment)
+ (scroll-up (or lines wl-message-scroll-amount)))
+ (scroll-up (or lines wl-message-scroll-amount)))
+ (end-of-buffer
+ (goto-char (point-max))))
+ (setq bottom nil))
+ (if (eobp)
+ (let ((f (assq (mime-preview-original-major-mode)
+ mime-preview-over-to-next-method-alist)))
+ (if f (funcall (cdr f))))))
bottom))
(wl-message-select-buffer wl-message-buffer)
(set-buffer message-buf)
+ (wl-deactivate-region)
(make-local-variable 'truncate-partial-width-windows)
(setq truncate-partial-width-windows nil)
(setq truncate-lines wl-message-truncate-lines)
(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
;; Use message buffer cache.
(defun wl-message-buffer-display (folder number flag
&optional force-reload unread)
- (let* ((msg-id (elmo-message-field folder number 'message-id))
+ (let* ((msg-id (ignore-errors (elmo-message-field folder number
+ 'message-id)))
(fname (elmo-folder-name-internal folder))
(hit (wl-message-buffer-cache-hit (list fname number msg-id)))
(read nil)
'wl-message-buffer-prefetch-subr
folder number count summary charset)))
-(defvar wl-message-buffer-prefetch-move-spec-plugged-alist nil)
-(defvar wl-message-buffer-prefetch-move-spec-unplugged-alist nil)
+(defvar wl-message-buffer-prefetch-move-spec-alist nil)
(defun wl-message-buffer-prefetch-get-next (folder number summary)
(if (buffer-live-p summary)
(with-current-buffer summary
- (let ((wl-summary-move-spec-plugged-alist
- (or wl-message-buffer-prefetch-move-spec-plugged-alist
- wl-summary-move-spec-plugged-alist))
- (wl-summary-move-spec-unplugged-alist
- (or wl-message-buffer-prefetch-move-spec-unplugged-alist
- wl-summary-move-spec-unplugged-alist))
+ (let ((wl-summary-move-spec-alist
+ (or wl-message-buffer-prefetch-move-spec-alist
+ wl-summary-move-spec-alist))
(next number))
(while (and (setq next (funcall
wl-message-buffer-prefetch-get-next-function
(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))