;;; Code:
;;
+(eval-when-compile (require 'cl))
+(eval-when-compile (require 'static))
(require 'wl-vars)
(require 'wl-highlight)
'wl-summary-default-get-next-msg)
(defvar wl-message-buffer-prefetch-debug nil)
-(defvar wl-message-buffer-prefetch-timer nil)
(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)
+(defvar wl-message-buffer-cur-display-type nil)
(defvar wl-message-buffer-cur-summary-buffer nil)
+(defvar wl-message-buffer-require-all-header nil)
(defvar wl-message-buffer-original-buffer nil) ; original buffer.
-(defvar wl-message-buffer-all-header-flag nil)
+(defvar wl-message-buffer-mode-line-formatter nil)
+(defvar wl-message-buffer-flag-indicator nil)
+(defvar wl-message-buffer-mime-entity nil)
(make-variable-buffer-local 'wl-message-buffer-cur-folder)
(make-variable-buffer-local 'wl-message-buffer-cur-number)
-(make-variable-buffer-local 'wl-message-buffer-cur-flag)
+(make-variable-buffer-local 'wl-message-buffer-cur-display-type)
(make-variable-buffer-local 'wl-message-buffer-cur-summary-buffer)
+(make-variable-buffer-local 'wl-message-buffer-require-all-header)
(make-variable-buffer-local 'wl-message-buffer-original-buffer)
-(make-variable-buffer-local 'wl-message-buffer-all-header-flag)
+(make-variable-buffer-local 'wl-message-buffer-mode-line-formatter)
+(make-variable-buffer-local 'wl-message-buffer-flag-indicator)
+(make-variable-buffer-local 'wl-message-buffer-mime-entity)
(defvar wl-fixed-window-configuration nil)
With association ((\"folder\" message \"message-id\") . cache-buffer).")
(defmacro wl-message-buffer-cache-buffer-get (entry)
- (` (cdr (, entry))))
+ `(cdr ,entry))
(defmacro wl-message-buffer-cache-folder-get (entry)
- (` (car (car (, entry)))))
+ `(car (car ,entry)))
(defmacro wl-message-buffer-cache-message-get (entry)
- (` (cdr (car (, entry)))))
+ `(cdr (car ,entry)))
(defmacro wl-message-buffer-cache-entry-make (key buf)
- (` (cons (, key) (, buf))))
+ `(cons ,key ,buf))
(defmacro wl-message-buffer-cache-hit (key)
"Return value assosiated with key."
- (` (wl-message-buffer-cache-buffer-get
- (assoc (, key) wl-message-buffer-cache))))
+ `(wl-message-buffer-cache-buffer-get
+ (assoc ,key wl-message-buffer-cache)))
(defun wl-message-buffer-cache-sort (entry)
"Move ENTRY to the top of `wl-message-buffer-cache'."
(setq wl-message-buffer-cache
(cons entry (delete entry wl-message-buffer-cache))))
-; (let* ((pointer (cons nil wl-message-buffer-cache))
-; (top pointer))
-; (while (cdr pointer)
-; (if (equal (car (cdr pointer)) entry)
-; (setcdr pointer (cdr (cdr pointer)))
-; (setq pointer (cdr pointer))))
-; (setcdr pointer (list entry))
-; (setq wl-message-buffer-cache (cdr top))))
-
-(defconst wl-message-buffer-cache-name " *WL:Message*")
+;;; (let* ((pointer (cons nil wl-message-buffer-cache))
+;;; (top pointer))
+;;; (while (cdr pointer)
+;;; (if (equal (car (cdr pointer)) entry)
+;;; (setcdr pointer (cdr (cdr pointer)))
+;;; (setq pointer (cdr pointer))))
+;;; (setcdr pointer (list entry))
+;;; (setq wl-message-buffer-cache (cdr top))))
+
(defconst wl-original-message-buffer-name " *Original*")
(defun wl-original-message-mode ()
"A major mode for original message buffer."
(setq major-mode 'wl-original-message-mode)
(setq buffer-read-only t)
- (elmo-set-buffer-multibyte nil)
+ (set-buffer-multibyte nil)
(setq mode-name "Wanderlust original message"))
(defun wl-original-message-buffer-get (name)
(defun wl-message-buffer-create ()
"Create a new message buffer."
- (let* ((buffer (generate-new-buffer wl-message-buffer-cache-name))
+ (let* ((buffer (generate-new-buffer wl-message-buffer-name))
(name (buffer-name buffer)))
(with-current-buffer buffer
(setq wl-message-buffer-original-buffer
- (wl-original-message-buffer-get name)))
+ (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))
(defun wl-message-buffer-cache-add (key)
(buf nil))
(if (< len wl-message-buffer-cache-size)
(setq buf (wl-message-buffer-create))
- (setq buf (wl-message-buffer-cache-buffer-get
- (nth (1- len) wl-message-buffer-cache)))
- (setcdr (nthcdr (- len 2) wl-message-buffer-cache) nil))
+ (let ((entry (nth (1- len) wl-message-buffer-cache)))
+ (if (buffer-live-p
+ (setq buf (wl-message-buffer-cache-buffer-get entry)))
+ (setcdr (nthcdr (- len 2) wl-message-buffer-cache) nil)
+ (setq wl-message-buffer-cache (delq entry wl-message-buffer-cache))
+ (setq buf (wl-message-buffer-create)))))
(setq wl-message-buffer-cache
(cons (wl-message-buffer-cache-entry-make key buf)
wl-message-buffer-cache))
wl-message-buffer
(get-buffer-window wl-message-buffer))
(delete-window (get-buffer-window wl-message-buffer)))
- (wl-kill-buffers (regexp-quote wl-message-buffer-cache-name))
+ (wl-kill-buffers (regexp-quote wl-message-buffer-name))
(setq wl-message-buffer-cache nil))
;;; Message buffer handling from summary buffer.
(mes (cdr wl-message-window-size))
whi)
(when (and window
- (not (eq (save-excursion (set-buffer (window-buffer window))
- wl-message-buffer-cur-summary-buffer)
+ (not (eq (with-current-buffer (window-buffer window)
+ wl-message-buffer-cur-summary-buffer)
(current-buffer))))
(delete-window window)
(run-hooks 'wl-message-window-deleted-hook)
"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 lines)
- (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 lines))
- (scroll-up lines))
- (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))
(setq mode-name "Message"))
(defun wl-message-exit ()
- "Move to summary buffer."
+ "Move to summary buffer or mother buffer."
(interactive)
- (let (summary-buf summary-win)
- (if (setq summary-buf wl-message-buffer-cur-summary-buffer)
- (if (setq summary-win (get-buffer-window summary-buf))
- (select-window summary-win)
- (switch-to-buffer summary-buf)
- (wl-message-select-buffer wl-message-buffer)
- (select-window (get-buffer-window summary-buf))))
+ (let (summary-buf summary-win mother-buffer)
+ (cond ((setq summary-buf wl-message-buffer-cur-summary-buffer)
+ (unless (buffer-live-p summary-buf)
+ (error "Summary buffer not found: %s"
+ wl-message-buffer-cur-folder))
+ (if (setq summary-win (get-buffer-window summary-buf))
+ (select-window summary-win)
+ (switch-to-buffer summary-buf)
+ (wl-message-select-buffer wl-message-buffer)
+ (select-window (get-buffer-window summary-buf))))
+ ((setq mother-buffer mime-mother-buffer)
+ (kill-buffer (current-buffer))
+ (when (buffer-live-p mother-buffer)
+ (switch-to-buffer mother-buffer))))
(run-hooks 'wl-message-exit-hook)))
(defun wl-message-toggle-disp-summary ()
(defun wl-message-get-original-buffer ()
"Get original buffer for current message buffer."
- wl-message-buffer-original-buffer)
+ (if (buffer-live-p wl-message-buffer-original-buffer)
+ wl-message-buffer-original-buffer
+ (wl-original-message-buffer-get (buffer-name (current-buffer)))))
(defun wl-message-add-buttons-to-body (start end)
(save-excursion
(nth 3 entry) (match-string (nth 4 entry))))
(goto-char end)))))))
-(defun wl-message-redisplay (folder number flag &optional force-reload)
+;; display-type object definition.
+(defun wl-message-make-display-type (mime header)
+ (let (symbol)
+ (prog1
+ (setq symbol (intern (format "%s-%s-header" mime header)))
+ (put symbol
+ 'wl-message-display-type
+ (list :mime mime :header header)))))
+
+(defun wl-message-display-type-property (display-type prop)
+ (plist-get (get display-type 'wl-message-display-type) prop))
+
+(defun wl-message-mime-analysis-p (display-type &optional header-or-body)
+ (let ((mode (wl-message-display-type-property display-type :mime)))
+ (case header-or-body
+ (header
+ (memq mode '(mime header-only)))
+ (t
+ (eq mode 'mime)))))
+
+(defun wl-message-display-all-header-p (display-type)
+ (eq (wl-message-display-type-property display-type :header) 'all))
+
+(defun wl-message-display-no-merge-p (display-type)
+ (eq (wl-message-display-type-property display-type :mime) 'no-merge))
+
+(defun wl-message-buffer-display-type (&optional message-buffer)
+ (if message-buffer
+ (with-current-buffer message-buffer
+ wl-message-buffer-cur-display-type)
+ wl-message-buffer-cur-display-type))
+
+(defun wl-message-flag-indicator (flags)
+ (let ((flags (elmo-get-global-flags flags)))
+ (if (null flags)
+ ""
+ (concat
+ " ("
+ (mapconcat
+ (lambda (flag)
+ (let ((indicator (capitalize (symbol-name flag)))
+ face)
+ (when (and (assq flag wl-summary-flag-alist)
+ (facep
+ (setq face (intern
+ (format "wl-highlight-summary-%s-flag-face"
+ flag)))))
+ (put-text-property 0 (length indicator) 'face face indicator))
+ indicator))
+ (sort flags
+ (lambda (l r)
+ (> (length (memq (assq l wl-summary-flag-alist)
+ wl-summary-flag-alist))
+ (length (memq (assq r wl-summary-flag-alist)
+ wl-summary-flag-alist)))))
+ ", ")
+ ")"))))
+
+(defun wl-message-redisplay (folder number display-type &optional force-reload)
(let* ((default-mime-charset wl-mime-charset)
(buffer-read-only nil)
(summary-buf (current-buffer))
- message-buf
- strategy entity
- cache-used
- header-end real-fld-num summary-win delim)
+ message-buf entity summary-win flags)
(setq buffer-read-only nil)
- (setq cache-used (wl-message-buffer-display
- folder number flag force-reload))
- (setq wl-message-buffer (car cache-used))
+ (setq wl-message-buffer (wl-message-buffer-display
+ folder number display-type force-reload))
(setq message-buf wl-message-buffer)
(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)
(setq wl-message-buffer-cur-summary-buffer summary-buf)
(setq wl-message-buffer-cur-folder (elmo-folder-name-internal folder))
(setq wl-message-buffer-cur-number number)
+ (setq wl-message-buffer-flag-indicator
+ (wl-message-flag-indicator (elmo-message-flags folder number)))
+ (wl-line-formatter-setup
+ wl-message-buffer-mode-line-formatter
+ wl-message-mode-line-format
+ wl-message-mode-line-format-spec-alist)
(setq mode-line-buffer-identification
- (format "Wanderlust: << %s / %s >>"
- (if (memq 'modeline wl-use-folder-petname)
- (wl-folder-get-petname (elmo-folder-name-internal
- folder))
- (elmo-folder-name-internal folder)) number))
- ;; highlight body
-; (when wl-highlight-body-too
-; (wl-highlight-body))
- (condition-case ()
- (wl-message-narrow-to-page)
- (error nil)); ignore errors.
- (setq cache-used (cdr cache-used))
+ (funcall wl-message-buffer-mode-line-formatter))
+;;; ;; highlight body
+;;; (when wl-highlight-body-too
+;;; (wl-highlight-body))
+ (ignore-errors (wl-message-narrow-to-page))
(goto-char (point-min))
(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 (and wl-message-use-header-narrowing
+ (not (wl-message-display-all-header-p display-type)))
+ (wl-message-header-narrowing))
(goto-char (point-min))
- (unwind-protect
- (save-excursion
- (run-hooks 'wl-message-redisplay-hook))
- ;; go back to summary mode
- (set-buffer-modified-p nil)
- (setq buffer-read-only t)
- (set-buffer summary-buf)
- (setq summary-win (get-buffer-window summary-buf))
- (if (window-live-p summary-win)
- (select-window summary-win)))
- cache-used))
+ (ignore-errors (run-hooks 'wl-message-redisplay-hook))
+ ;; go back to summary mode
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t)
+ (set-buffer summary-buf)
+ (setq summary-win (get-buffer-window summary-buf))
+ (if (window-live-p summary-win)
+ (select-window summary-win))))
;; Use message buffer cache.
-(defun wl-message-buffer-display (folder number flag
+(defun wl-message-buffer-display (folder number display-type
&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)
- cache-used)
+ (redisplay nil)
+ entity)
(when (and hit (not (buffer-live-p hit)))
(wl-message-buffer-cache-delete (list fname number msg-id))
(setq hit nil))
;; move hit to the top.
(wl-message-buffer-cache-sort
(wl-message-buffer-cache-entry-make (list fname number msg-id) hit))
- ;; buffer cache is used.
- (setq cache-used t)
(with-current-buffer hit
- (unless (eq wl-message-buffer-cur-flag flag)
- (setq read t))))
+ ;; Rewind to the top page
+ (widen)
+ (goto-char (point-min))
+ (ignore-errors (wl-message-narrow-to-page))
+ (setq entity wl-message-buffer-mime-entity)
+ (unless (eq wl-message-buffer-cur-display-type display-type)
+ (setq redisplay t))))
;; delete tail and add new to the top.
(setq hit (wl-message-buffer-cache-add (list fname number msg-id)))
- (setq read t))
- (if (or force-reload read)
- (condition-case err
- (save-excursion
- (set-buffer hit)
- (setq
- cache-used
- (wl-message-display-internal folder number flag
- force-reload unread))
- (setq wl-message-buffer-cur-flag flag))
- (quit
- (wl-message-buffer-cache-delete)
- (error "Display message %s/%s is quitted" fname number))
- (error
- (wl-message-buffer-cache-delete)
- (signal (car err) (cdr err))
- nil))) ;; will not be used
- (cons hit cache-used)))
-
-(defun wl-message-display-internal (folder number flag
- &optional force-reload unread)
- (let ((default-mime-charset wl-mime-charset))
- (setq wl-message-buffer-all-header-flag (eq flag 'all-header))
- (prog1
- (if (eq flag 'as-is)
- (let (wl-highlight-x-face-function)
- (prog1 (elmo-mime-display-as-is folder number
- (current-buffer)
- (wl-message-get-original-buffer)
- 'wl-original-message-mode
- force-reload
- unread
- (wl-message-define-keymap))
- (let (buffer-read-only)
- (wl-highlight-message (point-min) (point-max) t))))
- (elmo-mime-message-display folder number
- (current-buffer)
- (wl-message-get-original-buffer)
- 'wl-original-message-mode
- force-reload
- unread
- (wl-message-define-keymap)))
- (run-hooks 'wl-message-display-internal-hook)
- (setq buffer-read-only t))))
-
-(defsubst wl-message-buffer-prefetch-p (folder &optional number)
+ (setq redisplay t))
+ (when (or force-reload redisplay)
+ (condition-case err
+ (with-current-buffer hit
+ (when (or force-reload
+ (null entity)
+ (not (elmo-mime-entity-display-p
+ entity
+ (if (wl-message-mime-analysis-p display-type)
+ 'mime
+ 'as-is)))
+ (if (wl-message-display-no-merge-p display-type)
+ (elmo-mime-entity-reassembled-p entity)
+ (elmo-mime-entity-fragment-p entity)))
+ (setq entity (elmo-message-mime-entity
+ folder
+ number
+ (wl-message-get-original-buffer)
+ (and wl-message-auto-reassemble-message/partial
+ (not (wl-message-display-no-merge-p
+ display-type)))
+ force-reload
+ unread
+ (not (wl-message-mime-analysis-p display-type)))))
+ (unless entity
+ (error "Cannot display message %s/%s" fname number))
+ (wl-message-display-internal entity display-type))
+ (quit
+ (wl-message-buffer-cache-delete)
+ (error "Display message %s/%s is quitted" fname number))
+ (error
+ (wl-message-buffer-cache-delete)
+ (signal (car err) (cdr err))
+ nil))) ;; will not be used
+ hit))
+
+(defun wl-message-display-internal (entity display-type)
+ (let ((default-mime-charset wl-mime-charset)
+ (elmo-mime-charset wl-mime-charset)
+ (wl-message-buffer-require-all-header
+ (wl-message-display-all-header-p display-type)))
+ (if (wl-message-mime-analysis-p display-type)
+ (elmo-mime-entity-display entity
+ (current-buffer)
+ 'wl-original-message-mode
+ (wl-message-define-keymap))
+ (let* ((elmo-mime-display-header-analysis
+ (wl-message-mime-analysis-p display-type 'header))
+ (wl-highlight-x-face-function
+ (and elmo-mime-display-header-analysis
+ wl-highlight-x-face-function)))
+ (elmo-mime-entity-display-as-is entity
+ (current-buffer)
+ 'wl-original-message-mode
+ (wl-message-define-keymap))
+ (let (buffer-read-only)
+ (wl-highlight-message (point-min) (point-max) t))))
+ (setq wl-message-buffer-cur-display-type display-type
+ wl-message-buffer-mime-entity entity)
+ (run-hooks 'wl-message-display-internal-hook)
+ (setq buffer-read-only t)))
+
+(defun wl-message-buffer-prefetch-p (folder &optional number)
(and (or (not number)
(elmo-message-file-p folder number)
(let ((size (elmo-message-field folder number 'size)))
(t wl-message-buffer-prefetch-folder-list)))))
(defsubst wl-message-buffer-prefetch-clear-timer ()
-;;; cannot use for the bug of fsf-compat package (1.09).
-;;; (cancel-function-timers 'wl-message-buffer-prefetch-subr)
+;;; cannot use for the bug of fsf-compat package (1.09).
+;;; (cancel-function-timers 'wl-message-buffer-prefetch-subr)
(if (fboundp 'run-with-idle-timer)
(if (featurep 'xemacs)
(let ((p itimer-list))
'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))
- (next (funcall wl-message-buffer-prefetch-get-next-function
- number)))
- (if (and next
- (not (wl-message-buffer-prefetch-p folder next)))
- ;; for Multi folder
- (wl-message-buffer-prefetch-get-next
- folder next summary)
- next)))))
+ (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
+ next))
+ (not (wl-message-buffer-prefetch-p folder next))))
+ next))))
(defun wl-message-buffer-prefetch (folder number count
&optional summary charset)
(let* ((summary (or summary (get-buffer wl-summary-buffer-name)))
(num number))
- (when (and count
+ (when (and (> count 0)
(wl-message-buffer-prefetch-p folder))
(unless (wl-message-buffer-prefetch-p folder number)
(setq num
&optional summary charset)
(let* ((summary (or summary (get-buffer wl-summary-buffer-name)))
next)
- (when (and count
+ (when (and (> count 0)
(wl-message-buffer-prefetch-p folder))
(setq next (wl-message-buffer-prefetch-get-next folder number summary))
(when next
(key (list (elmo-folder-name-internal folder)
number message-id))
(hit (wl-message-buffer-cache-hit key))
- result time1 time2 sec micro)
+ (display-type (wl-message-make-display-type
+ wl-summary-buffer-display-mime-mode
+ wl-summary-buffer-display-header-mode))
+ time1 time2 sec micro)
(when wl-message-buffer-prefetch-debug
(message "%d: count %d, hit %s" number count (buffer-name hit)))
(if (and hit (buffer-live-p hit))
(when wl-message-buffer-prefetch-debug
(setq time1 (current-time))
(message "Prefetching %d..." number))
- (setq result (wl-message-buffer-display
- folder number 'mime nil 'unread))
+ (wl-message-buffer-display folder number
+ display-type nil 'unread)
+ (when (elmo-message-use-cache-p folder number)
+ (elmo-message-set-cached folder number t))
(when wl-message-buffer-prefetch-debug
(setq time2 (current-time))
(setq sec (- (nth 1 time2)(nth 1 time1)))
(when wl-message-buffer-prefetch-debug
(message "Buffer Cached Messages: %s"
(mapconcat
- '(lambda (cache)
- (if (numberp (nth 1 (car cache)))
- (if (string=
- (nth 0 (car cache))
- (elmo-folder-name-internal folder))
- (format "%d"
- (nth 1 (car cache)))
- (format "*%d" (nth 1 (car cache))))
- "-"))
+
+ (lambda (cache)
+ (if (numberp (nth 1 (car cache)))
+ (if (string=
+ (nth 0 (car cache))
+ (elmo-folder-name-internal folder))
+ (format "%d"
+ (nth 1 (car cache)))
+ (format "*%d" (nth 1 (car cache))))
+ "-"))
wl-message-buffer-cache " "))) )))
(defvar wl-message-button-map (make-sparse-keymap))
(wl-summary-redisplay)))
(defun wl-message-uu-substring (buf outbuf &optional first last)
- (save-excursion
- (set-buffer buf)
+ (with-current-buffer buf
(search-forward "\n\n")
(let ((sp (point))
ep filename case-fold-search)
(setq filename (buffer-substring (match-beginning 1)(match-end 1)))
(throw 'done nil)))
(re-search-forward "^M.*$" nil t)) ; uuencoded string
- (beginning-of-line)
- (setq sp (point))
+ (setq sp (point-at-bol))
(goto-char (point-max))
(if last
(re-search-backward "^end" sp t)
(re-search-backward "^M.*$" sp t)) ; uuencoded string
(forward-line 1)
(setq ep (point))
- (set-buffer outbuf)
- (goto-char (point-max))
- (insert-buffer-substring buf sp ep)
- (set-buffer buf)
+ (with-current-buffer outbuf
+ (goto-char (point-max))
+ (insert-buffer-substring buf sp ep))
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 (mouse-set-point 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))
projects / elisp / wanderlust.git / blobdiff