X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-message.el;h=c094061ffbfe19fa32255155b2989464ca95d9e8;hb=c20fb61cd99f50dd4eb03aa29a40b44c802efe17;hp=56621e0e02bb1eaafb51516b2eac52ba5a549aa1;hpb=50e87247bc89cd4eead8633be07a758798831042;p=elisp%2Fwanderlust.git diff --git a/wl/wl-message.el b/wl/wl-message.el index 56621e0..c094061 100644 --- a/wl/wl-message.el +++ b/wl/wl-message.el @@ -1,4 +1,4 @@ -;;; wl-message.el -- Message displaying modules for Wanderlust. +;;; wl-message.el --- Message displaying modules for Wanderlust. ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi @@ -24,15 +24,16 @@ ;; ;;; Commentary: -;; +;; ;;; Code: -;; +;; (require 'wl-vars) (require 'wl-highlight) (require 'elmo) (require 'elmo-mime) +(require 'timer) (eval-when-compile (require 'wl-mime) @@ -40,16 +41,16 @@ (defalias-maybe 'event-window 'ignore) (defalias-maybe 'posn-window 'ignore) (defalias-maybe 'event-start 'ignore) - (defalias-maybe 'mime-open-entity 'ignore)) + (defalias-maybe 'mime-open-entity 'ignore) + (defalias-maybe 'itimer-function 'ignore) + (defalias-maybe 'delete-itimer 'ignore) + (defvar-maybe itimer-list)) -(defconst wl-message-buffer-prefetch-idle-time - (if (featurep 'lisp-float-type) (/ (float 1) (float 5)) 1)) (defvar wl-message-buffer-prefetch-get-next-function 'wl-summary-default-get-next-msg) -(defvar wl-message-buffer-prefetch-folder-type-list t) - (defvar wl-message-buffer-prefetch-debug nil) +(defvar wl-message-buffer-prefetch-timer nil) (defvar wl-message-buffer nil) ; message buffer. @@ -59,12 +60,16 @@ (defvar wl-message-buffer-cur-flag nil) (defvar wl-message-buffer-cur-summary-buffer 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) (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-summary-buffer) (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) (defvar wl-fixed-window-configuration nil) @@ -106,7 +111,6 @@ With association ((\"folder\" message \"message-id\") . cache-buffer).") ; (setcdr pointer (list entry)) ; (setq wl-message-buffer-cache (cdr top)))) -(defconst wl-message-buffer-cache-name " *WL:Message*") (defconst wl-original-message-buffer-name " *Original*") (defun wl-original-message-mode () @@ -128,11 +132,12 @@ If original message buffer already exists, it is re-used." (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)) + (run-hooks 'wl-message-buffer-created-hook)) buffer)) (defun wl-message-buffer-cache-add (key) @@ -169,7 +174,7 @@ Return its cache buffer." 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. @@ -203,9 +208,9 @@ Return its cache buffer." (if window (select-window window) (when wl-fixed-window-configuration - (delete-other-windows) - (and wl-stay-folder-window - (wl-summary-toggle-disp-folder))) + (delete-other-windows) + (and wl-stay-folder-window + (wl-summary-toggle-disp-folder))) ;; There's no buffer window. Search for message window and snatch it. (if (setq window (wl-message-buffer-window)) (select-window window) @@ -228,7 +233,7 @@ If ARG is specified, narrow to ARGth page." (setq arg (if arg (prefix-numeric-value arg) 0)) (save-excursion (condition-case () - (forward-page -1) ; Beginning of current page. + (forward-page -1) ; Beginning of current page. (beginning-of-buffer (goto-char (point-min)))) (forward-char 1) ; for compatibility with emacs-19.28 and emacs-19.29 @@ -264,7 +269,7 @@ Returns non-nil if top of message." (recenter)) (if (not (bobp)) (condition-case nil - (scroll-down lines) + (scroll-down (or lines wl-message-scroll-amount)) (error)) (setq top t))) (if real-top @@ -300,8 +305,8 @@ Returns non-nil if bottom of message." (static-if (boundp 'window-pixel-scroll-increment) ;; XEmacs 21.2.20 and later. (let (window-pixel-scroll-increment) - (scroll-up lines)) - (scroll-up lines)) + (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)) @@ -321,7 +326,7 @@ Returns non-nil if bottom of message." (let ((mail-reply-buffer buffer)) (wl-draft-yank-from-mail-reply-buffer nil))) -;; +;; (defun wl-message-mode () "A major mode for message displaying." @@ -354,14 +359,59 @@ Returns non-nil if bottom of message." (wl-message-select-buffer wl-message-buffer)) (wl-summary-goto-folder-subr wl-message-buffer-cur-folder 'no-sync nil nil t) - ; no summary-buf + ; no summary-buf (let ((sum-buf (current-buffer))) (wl-message-select-buffer wl-message-buffer) (setq wl-message-buffer-cur-summary-buffer sum-buf))))) (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 + (save-restriction + (narrow-to-region start end) + (let ((case-fold-search t) + (alist wl-message-body-button-alist) + entry) + (while alist + (setq entry (car alist) + alist (cdr alist)) + (goto-char (point-min)) + (while (re-search-forward (car entry) (+ (point) (nth 4 entry)) t) + (unless (get-text-property (point) 'keymap) + (wl-message-add-button + (match-beginning (nth 1 entry)) + (match-end (nth 1 entry)) + (nth 2 entry) + (match-string (nth 3 entry)))))))))) + +(defun wl-message-add-buttons-to-header (start end) + (save-excursion + (save-restriction + (narrow-to-region start end) + (let ((case-fold-search t) + (alist wl-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) + (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-message-redisplay (folder number flag &optional force-reload) (let* ((default-mime-charset wl-mime-charset) @@ -370,7 +420,7 @@ Returns non-nil if bottom of message." message-buf strategy entity cache-used - header-end real-fld-num summary-win) + header-end real-fld-num summary-win delim) (setq buffer-read-only nil) (setq cache-used (wl-message-buffer-display folder number flag force-reload)) @@ -379,35 +429,37 @@ Returns non-nil if bottom of message." (wl-message-select-buffer wl-message-buffer) (set-buffer message-buf) + (make-local-variable 'truncate-partial-width-windows) + (setq truncate-partial-width-windows nil) + (setq truncate-lines wl-message-truncate-lines) (setq buffer-read-only nil) (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) - (wl-message-overload-functions) + (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)) + (funcall wl-message-buffer-mode-line-formatter)) ;; highlight body ; (when wl-highlight-body-too ; (wl-highlight-body)) - (condition-case () - (wl-message-narrow-to-page) - (error nil)); ignore errors. + (ignore-errors (wl-message-narrow-to-page)) (setq cache-used (cdr cache-used)) (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))) + (when (re-search-forward "^$" nil t) + (wl-message-add-buttons-to-header (point-min) (point)) + (wl-message-add-buttons-to-body (point) (point-max))) + (goto-char (point-min)) + (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)) cache-used)) ;; Use message buffer cache. @@ -429,6 +481,10 @@ Returns non-nil if bottom of message." ;; buffer cache is used. (setq cache-used t) (with-current-buffer hit + ;; Rewind to the top page + (widen) + (goto-char (point-min)) + (ignore-errors (wl-message-narrow-to-page)) (unless (eq wl-message-buffer-cur-flag flag) (setq read t)))) ;; delete tail and add new to the top. @@ -454,105 +510,197 @@ Returns non-nil if bottom of message." (defun wl-message-display-internal (folder number flag &optional force-reload unread) - (let ((elmo-message-ignored-field-list - (if (eq flag 'all-header) - nil - wl-message-ignored-field-list)) - (elmo-message-visible-field-list wl-message-visible-field-list) - (elmo-message-sorted-field-list wl-message-sort-field-list) - (elmo-message-fetch-threshold wl-fetch-confirm-threshold)) - (prog1 + (let ((default-mime-charset wl-mime-charset) + (elmo-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) - (elmo-mime-display-as-is folder number - (current-buffer) - (wl-message-get-original-buffer) - 'wl-original-message-mode - force-reload - unread)) + (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)) + 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) - (cond - ((eq wl-message-buffer-prefetch-folder-type-list t) - t) - ((and number wl-message-buffer-prefetch-folder-type-list) - (memq (elmo-folder-type-internal - (elmo-message-folder folder number)) - wl-message-buffer-prefetch-folder-type-list)) - (wl-message-buffer-prefetch-folder-type-list - (let ((list wl-message-buffer-prefetch-folder-type-list) - type) - (catch 'done - (while (setq type (pop list)) - (if (elmo-folder-contains-type folder type) - (throw 'done t)))))) - ((consp wl-message-buffer-prefetch-folder-type-list) - (wl-string-match-member (elmo-folder-name-internal folder) - wl-message-buffer-prefetch-folder-type-list)) - (t wl-message-buffer-prefetch-folder-type-list))) - - -(defvar wl-message-buffer-prefetch-timer nil) - -(defun wl-message-buffer-prefetch-next (folder number &optional - summary charset) - (if (wl-message-buffer-prefetch-p folder) - (with-current-buffer (or summary (get-buffer wl-summary-buffer-name)) - (let* ((next (funcall wl-message-buffer-prefetch-get-next-function - number))) - (when (and next (wl-message-buffer-prefetch-p folder next)) - (if (not (fboundp 'run-with-idle-timer)) - (when (sit-for wl-message-buffer-prefetch-idle-time) - (wl-message-buffer-prefetch folder next summary charset)) - (unless wl-message-buffer-prefetch-timer - (setq wl-message-buffer-prefetch-timer - (run-with-idle-timer - wl-message-buffer-prefetch-idle-time - nil - 'wl-message-buffer-prefetch - folder next summary charset))))))))) - -(defun wl-message-buffer-prefetch (folder number summary charset) - (when (buffer-live-p summary) - (save-excursion - (set-buffer summary) - (when (string= (elmo-folder-name-internal folder) - (wl-summary-buffer-folder-name)) - (let ((message-id (elmo-message-field folder number 'message-id)) - (wl-mime-charset charset) - (default-mime-charset charset) - result time1 time2 sec micro) - (if (not (wl-message-buffer-cache-hit (list folder - number message-id))) - (let* ((size (elmo-message-field folder number 'size))) - (when (or (elmo-message-file-p folder number) - (not - (and (integerp size) - elmo-message-fetch-threshold - (>= size - elmo-message-fetch-threshold)))) - ;;(not (elmo-file-cache-exists-p message-id))))) - (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)) - (when wl-message-buffer-prefetch-debug - (setq time2 (current-time)) - (setq sec (- (nth 1 time2)(nth 1 time1))) - (setq micro (- (nth 2 time2)(nth 2 time1))) - (setq micro (+ micro (* 1000000 sec))) - (message "Prefetching %d...done(%f msec)." - number - (/ micro 1000.0)))))))))) - (setq wl-message-buffer-prefetch-timer nil)) + (and (or (not number) + (elmo-message-file-p folder number) + (let ((size (elmo-message-field folder number 'size))) + (not (and (integerp size) + wl-message-buffer-prefetch-threshold + (>= size wl-message-buffer-prefetch-threshold))))) + (or (not number) + (elmo-folder-plugged-p folder) + (elmo-file-cache-exists-p + (elmo-message-field folder number 'message-id))) + (or (cond + ((eq wl-message-buffer-prefetch-folder-type-list t) + t) + ((and number wl-message-buffer-prefetch-folder-type-list) + (memq (elmo-folder-type-internal + (elmo-message-folder folder number)) + wl-message-buffer-prefetch-folder-type-list)) + (wl-message-buffer-prefetch-folder-type-list + (let ((list wl-message-buffer-prefetch-folder-type-list) + type) + (catch 'done + (while (setq type (pop list)) + (if (elmo-folder-contains-type folder type) + (throw 'done t))))))) + (cond + ((consp wl-message-buffer-prefetch-folder-list) + (wl-string-match-member (elmo-folder-name-internal folder) + wl-message-buffer-prefetch-folder-list)) + (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) + (if (fboundp 'run-with-idle-timer) + (if (featurep 'xemacs) + (let ((p itimer-list)) + (while (car p) + (if (eq 'wl-message-buffer-prefetch-subr + (itimer-function (car p))) + (delete-itimer (car p))) + (setq p (cdr p)))) + ;; FSF Emacs is correct + (cancel-function-timers 'wl-message-buffer-prefetch-subr)))) + +(defsubst wl-message-buffer-prefetch-set-timer (folder number count + summary charset) + (if (not (fboundp 'run-with-idle-timer)) + (when (sit-for wl-message-buffer-prefetch-idle-time) + (wl-message-buffer-prefetch-subr + folder number count summary charset)) + (run-with-idle-timer + wl-message-buffer-prefetch-idle-time + 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) + +(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 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 + (wl-message-buffer-prefetch-p folder)) + (unless (wl-message-buffer-prefetch-p folder number) + (setq num + (wl-message-buffer-prefetch-get-next folder number summary))) + (when num + (wl-message-buffer-prefetch-clear-timer) + (wl-message-buffer-prefetch-set-timer + folder num count summary charset))))) + +(defun wl-message-buffer-prefetch-next (folder number count + &optional summary charset) + (let* ((summary (or summary (get-buffer wl-summary-buffer-name))) + next) + (when (and count + (wl-message-buffer-prefetch-p folder)) + (setq next (wl-message-buffer-prefetch-get-next folder number summary)) + (when next + (wl-message-buffer-prefetch-clear-timer) + (wl-message-buffer-prefetch-set-timer + folder next count summary charset))))) + +(defun wl-message-buffer-prefetch-subr (folder number count summary charset) + (if (buffer-live-p summary) + (with-current-buffer summary + (if (and number + (numberp count) + (>= (setq count (- count 1)) 0) + (string= (elmo-folder-name-internal folder) + (wl-summary-buffer-folder-name))) + (let* ((wl-mime-charset charset) + (default-mime-charset charset) + (message-id (elmo-message-field folder number 'message-id)) + (key (list (elmo-folder-name-internal folder) + number message-id)) + (hit (wl-message-buffer-cache-hit key)) + result 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)) + (progn + (wl-message-buffer-cache-sort + (wl-message-buffer-cache-entry-make key hit)) + (wl-message-buffer-prefetch-subr + folder + (wl-message-buffer-prefetch-get-next + folder number summary) + count summary charset)) + ;; prefetching + (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)) + (when wl-message-buffer-prefetch-debug + (setq time2 (current-time)) + (setq sec (- (nth 1 time2)(nth 1 time1))) + (setq micro (- (nth 2 time2)(nth 2 time1))) + (setq micro (+ micro (* 1000000 sec))) + (message "Prefetching %d...done(%f msec)." + number + (/ micro 1000.0)) + (sit-for 0)) + ;; set next prefetch + (wl-message-buffer-prefetch-set-timer + folder + (wl-message-buffer-prefetch-get-next + folder number summary) + count summary charset) + (sit-for 0) + ;; success prefetch + ))) + ;; finish prefetch + (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)))) + "-")) + wl-message-buffer-cache " "))) ))) (defvar wl-message-button-map (make-sparse-keymap)) @@ -585,34 +733,6 @@ Returns non-nil if bottom of message." (if (wl-summary-jump-to-msg-by-message-id data) (wl-summary-redisplay))) -(defun wl-message-refer-article-or-url (e) - "Read article specified by message-id around point. -If failed, attempt to execute button-dispatcher." - (interactive "e") - (let ((window (get-buffer-window (current-buffer))) - mouse-window point beg end msg-id) - (unwind-protect - (progn - (mouse-set-point e) - (setq mouse-window (get-buffer-window (current-buffer))) - (setq point (point)) - (setq beg (save-excursion (beginning-of-line) (point))) - (setq end (save-excursion (end-of-line) (point))) - (search-forward ">" end t) ;Move point to end of "<....>". - (if (and (re-search-backward "\\(<[^<> \t\n]+@[^<> \t\n]+>\\)" - beg t) - (not (string-match "mailto:" - (setq msg-id (wl-match-buffer 1))))) - (progn - (goto-char point) - (switch-to-buffer-other-window - wl-message-buffer-cur-summary-buffer) - (if (wl-summary-jump-to-msg-by-message-id msg-id) - (wl-summary-redisplay))) - (wl-message-button-dispatcher-internal e))) - (if (eq mouse-window (get-buffer-window (current-buffer))) - (select-window window))))) - (defun wl-message-uu-substring (buf outbuf &optional first last) (save-excursion (set-buffer buf)