1 ;;; wl-message.el -- Message displaying modules for Wanderlust.
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Keywords: mail, net news
8 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
33 (require 'wl-highlight)
40 (require 'mmelmo-imap4))
42 (defalias-maybe 'event-window 'ignore)
43 (defalias-maybe 'posn-window 'ignore)
44 (defalias-maybe 'event-start 'ignore)
45 (defalias-maybe 'mime-open-entity 'ignore))
47 (defvar wl-original-buf-name "*Message*")
48 (defvar wl-message-buf-name "Message")
49 (defvar wl-message-buffer-cur-summary-buffer nil)
50 (defvar wl-message-buffer-cur-folder nil)
51 (defvar wl-message-buffer-cur-number nil)
53 (defvar wl-original-buffer-cur-folder nil)
54 (defvar wl-original-buffer-cur-number nil)
55 (defvar wl-original-buffer-cur-msgdb nil)
57 (defvar mmelmo-imap4-skipped-parts)
59 (make-variable-buffer-local 'wl-message-buffer-cur-folder)
60 (make-variable-buffer-local 'wl-message-buffer-cur-number)
63 (product-provide (provide 'wl-message) (require 'wl-version))
65 (defvar wl-fixed-window-configuration nil)
67 (defun wl-message-buffer-window ()
68 (let* ((mes-buf (concat "^" (default-value 'wl-message-buf-name)))
69 (start-win (selected-window))
73 (setq cur-win (next-window cur-win))
74 (if (string-match mes-buf (buffer-name (window-buffer cur-win)))
75 (throw 'found cur-win))
76 (not (eq cur-win start-win)))))))
78 (defun wl-select-buffer (buffer)
79 (let ((gbw (or (get-buffer-window buffer)
80 (wl-message-buffer-window)))
81 (sum (car wl-message-window-size))
82 (mes (cdr wl-message-window-size))
85 (not (eq (save-excursion (set-buffer (window-buffer gbw))
86 wl-message-buffer-cur-summary-buffer)
89 (run-hooks 'wl-message-window-deleted-hook)
93 ;;; (if (or (null mes)
94 ;;; wl-stay-folder-window)
95 ;;; (delete-other-windows))
96 (when wl-fixed-window-configuration
97 (delete-other-windows)
98 (and wl-stay-folder-window
99 (wl-summary-toggle-disp-folder)))
100 (setq whi (1- (window-height)))
103 (let ((total (+ sum mes)))
104 (setq sum (max window-min-height (/ (* whi sum) total)))
105 (setq mes (max window-min-height (/ (* whi mes) total))))
106 (if (< whi (+ sum mes))
107 (enlarge-window (- (+ sum mes) whi)))))
108 (split-window (get-buffer-window (current-buffer)) sum)
110 (switch-to-buffer buffer)))
113 ;; called by wl-summary-mode buffer
115 (defvar wl-message-func-called-hook nil)
117 (defun wl-message-scroll-down (amount)
118 (let ((view-message-buffer (get-buffer-create wl-message-buf-name))
119 (cur-buf (current-buffer)))
120 (wl-select-buffer view-message-buffer)
124 (select-window (get-buffer-window cur-buf))))
126 (defun wl-message-scroll-up (amount)
127 (let ((view-message-buffer (get-buffer-create wl-message-buf-name))
128 (cur-buf (current-buffer)))
129 (wl-select-buffer view-message-buffer)
134 (if (pos-visible-in-window-p (point))
135 (wl-message-narrow-to-page 1)))) ; Go to next page.
139 (select-window (get-buffer-window cur-buf))))
141 (defun wl-message-follow-current-entity (buffer)
142 "Follow to current message."
143 (wl-draft-reply (wl-message-get-original-buffer)
144 'to-all wl-message-buffer-cur-summary-buffer)
145 (let ((mail-reply-buffer buffer))
146 (wl-draft-yank-from-mail-reply-buffer nil)))
148 (defun wl-message-original-mode ()
149 (setq major-mode 'wl-message-original-mode)
150 (setq mode-name "Original")
151 (setq buffer-read-only t)
152 (if (fboundp 'set-buffer-file-coding-system)
153 (set-buffer-file-coding-system wl-cs-noconv)))
155 (defun wl-message-mode ()
157 (setq major-mode 'wl-message-mode)
158 (setq buffer-read-only t)
159 (setq mode-name "Message"))
161 (defun wl-message-get-buffer-create ()
162 (let ((buf-name wl-message-buf-name))
163 (or (get-buffer buf-name)
165 (set-buffer (get-buffer-create buf-name))
167 (run-hooks 'wl-message-buffer-created-hook)
168 (get-buffer buf-name)))))
170 (defun wl-message-original-get-buffer-create ()
171 (or (get-buffer wl-original-buf-name)
173 (set-buffer (get-buffer-create wl-original-buf-name))
174 (wl-message-original-mode)
175 (get-buffer wl-original-buf-name))))
177 (defun wl-message-exit ()
179 (let (summary-buf summary-win)
180 (if (setq summary-buf wl-message-buffer-cur-summary-buffer)
181 (if (setq summary-win (get-buffer-window summary-buf))
182 (select-window summary-win)
183 (switch-to-buffer summary-buf)
184 (wl-select-buffer wl-message-buf-name)
185 (select-window (get-buffer-window summary-buf))))
186 (run-hooks 'wl-message-exit-hook)))
188 (defun wl-message-decode (outbuf inbuf flag)
190 ((eq flag 'all-header)
193 (let ((buffer-read-only nil))
194 (decode-mime-charset-region (point-min)
196 (goto-char (point-min))
197 (re-search-forward "^$" nil t)
200 (wl-message-decode-with-all-header outbuf inbuf))
204 (let ((buffer-read-only nil))
207 (elmo-set-buffer-multibyte nil))
208 (copy-to-buffer outbuf (point-min) (point-max))
210 (local-set-key "q" 'wl-message-exit)
211 (local-set-key "p" 'wl-message-exit)
212 (local-set-key "n" 'wl-message-exit)
213 (elmo-set-buffer-multibyte default-enable-multibyte-characters)
214 ;;; (decode-mime-charset-region (point-min) (point-max) wl-mime-charset)
215 ;; we can call decode-coding-region() directly, because multibyte flag is t.
216 (decode-coding-region (point-min) (point-max) wl-cs-autoconv)
217 (wl-highlight-message (point-min)
219 (goto-char (point-min))
220 (re-search-forward "^$" nil t)) nil))))
224 (let ((buffer-read-only nil))
225 (decode-mime-charset-region (point-min)
227 (goto-char (point-min))
228 (re-search-forward "^$" nil t)
231 (wl-message-decode-mode outbuf inbuf))))
233 (defun wl-message-prev-page (&optional lines)
234 "Scroll down this message. Returns non-nil if top of message."
236 (let ((cur-buf (current-buffer))
237 (view-message-buffer (get-buffer-create wl-message-buf-name))
239 (wl-select-buffer view-message-buffer)
240 (move-to-window-line 0)
241 (if (and wl-break-pages
243 (not (save-restriction (widen) (bobp))))
245 (wl-message-narrow-to-page -1)
246 (goto-char (point-max))
251 (select-window (get-buffer-window cur-buf))
254 (static-if (fboundp 'luna-make-entity)
255 (defsubst wl-message-make-mime-entity (backend number backend folder msgdb)
256 (luna-make-entity (mm-expand-class-name 'elmo)
257 :location (get-buffer-create
258 (concat mmelmo-entity-buffer-name "0"))
259 :imap (eq backend 'elmo-imap4)
262 :msgdb msgdb :size 0))
263 (defsubst wl-message-make-mime-entity (backend number backend folder msgdb)
264 (mime-open-entity backend (list folder number msgdb nil))))
266 (defun wl-message-next-page (&optional lines)
267 "Scroll up this message. Returns non-nil if bottom of message."
269 (let ((cur-buf (current-buffer))
270 (view-message-buffer (get-buffer-create wl-message-buf-name))
272 (wl-select-buffer view-message-buffer)
273 (move-to-window-line -1)
276 (and (pos-visible-in-window-p)
278 (if (or (null wl-break-pages)
281 (widen) (forward-line) (eobp))))
283 (wl-message-narrow-to-page 1)
288 (goto-char (point-max))))
290 (select-window (get-buffer-window cur-buf))
294 (defun wl-message-narrow-to-page (&optional arg)
296 (setq arg (if arg (prefix-numeric-value arg) 0))
299 (forward-page -1) ; Beginning of current page.
301 (goto-char (point-min))))
302 (forward-char 1) ; for compatibility with emacs-19.28 and emacs-19.29
305 ((> arg 0) (forward-page arg))
306 ((< arg 0) (forward-page (1- arg))))
309 (narrow-to-region (point)
312 (if (and (eolp) (not (bobp)))
316 (defun wl-message-toggle-disp-summary ()
318 (let ((summary-buf (get-buffer wl-message-buffer-cur-summary-buffer))
321 (buffer-live-p summary-buf))
322 (if (setq summary-win (get-buffer-window summary-buf))
323 (delete-window summary-win)
324 (switch-to-buffer summary-buf)
325 (wl-select-buffer wl-message-buf-name))
326 (wl-summary-goto-folder-subr wl-message-buffer-cur-folder 'no-sync
329 (let ((sum-buf (current-buffer)))
330 (wl-select-buffer wl-message-buf-name)
331 (setq wl-message-buffer-cur-summary-buffer sum-buf)))))
333 (defun wl-message-normal-get-original-buffer ()
334 (let ((ret-val (get-buffer wl-original-buf-name)))
337 (set-buffer (setq ret-val
338 (get-buffer-create wl-original-buf-name)))
339 (wl-message-original-mode)))
344 (defalias 'wl-message-get-original-buffer
345 'mmelmo-get-original-buffer)
346 (defalias 'wl-message-get-original-buffer
347 'wl-message-normal-get-original-buffer))
349 (defvar wl-message-redisplay-func 'wl-normal-message-redisplay)
350 (defvar wl-message-cache-used nil) ;whether cache is used or not.
352 (defun wl-message-redisplay (folder number flag msgdb &optional force-reload)
353 (let ((default-mime-charset wl-mime-charset)
354 (buffer-read-only nil))
355 (setq wl-message-cache-used nil)
356 (if wl-message-redisplay-func
357 (funcall wl-message-redisplay-func
358 folder number flag msgdb force-reload))))
360 ;; nil means don't fetch all.
361 (defun wl-message-decide-backend (folder number message-id size)
362 (let ((dont-do-that (and
363 (not (setq wl-message-cache-used
365 (elmo-buffer-cache-hit
366 (list folder number message-id))
367 (elmo-cache-exists-p message-id
370 (not (elmo-local-file-p folder number))
371 wl-fetch-confirm-threshold
372 (>= size wl-fetch-confirm-threshold)
374 (format "Fetch entire message? (%dbytes)"
377 (cond ((and dont-do-that
378 (eq (elmo-folder-number-get-type folder number) 'imap4)
379 (not (and (elmo-use-cache-p folder number)
380 (elmo-cache-exists-p message-id folder number))))
382 (t (if (not dont-do-that) 'elmo)))))
384 (defmacro wl-message-original-buffer-folder ()
385 wl-original-buffer-cur-folder)
387 (defmacro wl-message-original-buffer-number ()
388 wl-original-buffer-cur-number)
390 (defun wl-message-set-original-buffer-information (folder number)
391 (when (or (not (string= folder (or wl-original-buffer-cur-folder "")))
392 (not (eq number (or wl-original-buffer-cur-number 0))))
393 (setq wl-original-buffer-cur-folder folder)
394 (setq wl-original-buffer-cur-number number)))
396 ;; Works on FLIM-1.9.0/SEMI-1.8.2 or later (maybe).
397 (defun wl-mmelmo-message-redisplay (folder number flag msgdb
398 &optional force-reload)
399 (let* ((cur-buf (current-buffer))
400 (view-message-buffer (wl-message-get-buffer-create))
401 (message-id (cdr (assq number
402 (elmo-msgdb-get-number-alist msgdb))))
403 (size (elmo-msgdb-overview-entity-get-size
404 (elmo-msgdb-overview-get-entity number msgdb)))
405 (backend (wl-message-decide-backend folder number message-id size))
406 cur-entity ret-val header-end real-fld-num summary-win)
408 (wl-select-buffer view-message-buffer)
409 (set-buffer view-message-buffer)
412 (setq wl-message-buffer-cur-summary-buffer cur-buf)
413 (setq wl-message-buffer-cur-folder folder)
414 (setq wl-message-buffer-cur-number number)
415 (setq buffer-read-only nil)
418 (let (mime-display-header-hook ;; bind to nil...
419 (wl-message-ignored-field-list
420 (if (eq flag 'all-header)
422 wl-message-ignored-field-list))
423 (mmelmo-force-reload force-reload)
424 (mmelmo-imap4-threshold wl-fetch-confirm-threshold))
425 (setq real-fld-num (elmo-get-real-folder-number
428 (wl-message-make-mime-entity
430 (if (eq backend 'elmo-imap4)
434 (if (eq backend 'elmo-imap4)
438 (setq mmelmo-imap4-skipped-parts nil)
439 ;; mime-display-message sets buffer-read-only variable as t.
440 ;; which makes buffer read-only status confused...
441 (mime-display-message cur-entity view-message-buffer
442 nil nil 'mmelmo-original-mode)
443 (if mmelmo-imap4-skipped-parts
445 (message "Skipped fetching of %s."
449 mmelmo-imap4-skipped-parts ","))))
450 (if (and (eq backend 'elmo-imap4)
451 (null mmelmo-imap4-skipped-parts))
452 (message "No required part was skipped."))
453 (setq ret-val (not (eq backend 'elmo-imap4))))
454 (message "Skipped fetching.")
456 (setq buffer-read-only nil)
457 (wl-message-set-original-buffer-information folder number)
458 (wl-message-overload-functions)
460 (when wl-highlight-body-too
463 (wl-message-narrow-to-page)
464 (error nil));; ignore errors.
465 (setq mode-line-buffer-identification
466 (format "Wanderlust: << %s / %s >>"
467 (if (memq 'modeline wl-use-folder-petname)
468 (wl-folder-get-petname folder)
470 (goto-char (point-min))
473 (run-hooks 'wl-message-redisplay-hook))
474 ;; go back to summary mode
475 (set-buffer-modified-p nil)
476 (setq buffer-read-only t)
478 (setq summary-win (get-buffer-window cur-buf))
479 (if (window-live-p summary-win)
480 (select-window summary-win))))
484 (defun wl-normal-message-redisplay (folder number flag msgdb
485 &optional force-reload)
487 (let* ((cur-buf (current-buffer))
488 (original-message-buffer (wl-message-get-original-buffer))
489 (view-message-buffer (wl-message-get-buffer-create))
490 (message-id (cdr (assq number
491 (elmo-msgdb-get-number-alist msgdb))))
492 (size (elmo-msgdb-overview-entity-get-size
493 (elmo-msgdb-overview-get-entity number msgdb)))
494 header-end ret-val summary-win)
495 (wl-select-buffer view-message-buffer)
498 (setq wl-message-buffer-cur-summary-buffer cur-buf)
499 (setq wl-message-buffer-cur-folder folder)
500 (setq wl-message-buffer-cur-number number)
501 (setq buffer-read-only nil)
503 (if (or (eq (elmo-folder-number-get-type folder number) 'localdir)
504 (not (and (integerp size)
505 wl-fetch-confirm-threshold
506 (>= size wl-fetch-confirm-threshold)
507 (not (elmo-cache-exists-p message-id
510 (format "Fetch entire message? (%dbytes)"
514 (set-buffer original-message-buffer)
515 (let ((buffer-read-only nil))
516 (elmo-read-msg-with-buffer-cache
517 folder number original-message-buffer msgdb force-reload)))
518 ;; decode MIME message.
521 original-message-buffer flag)
524 (set-buffer view-message-buffer)
526 (setq buffer-read-only nil)
527 (wl-message-set-original-buffer-information folder number)
528 (wl-message-overload-functions)
530 (and wl-highlight-body-too (wl-highlight-body))
532 (wl-message-narrow-to-page)
533 (error nil)) ; ignore errors.
534 (setq mode-line-buffer-identification
535 (format "Wanderlust: << %s / %s >>"
536 (if (memq 'modeline wl-use-folder-petname)
537 (wl-folder-get-petname folder)
540 (goto-char (point-min))
542 (run-hooks 'wl-message-redisplay-hook)
543 ;; go back to summary mode
544 (set-buffer-modified-p nil)
545 (setq buffer-read-only t)
547 (setq summary-win (get-buffer-window cur-buf))
548 (if (window-live-p summary-win)
549 (select-window summary-win)))
553 (defvar wl-message-button-map (make-sparse-keymap))
555 (defun wl-message-add-button (from to function &optional data)
556 "Create a button between FROM and TO with callback FUNCTION and DATA."
559 (nconc (list 'wl-message-button-callback function)
561 (list 'wl-message-button-data data))))
562 (let ((ov (make-overlay from to)))
563 (overlay-put ov 'mouse-face 'highlight)
564 (overlay-put ov 'local-map wl-message-button-map)
565 (overlay-put ov 'evaporate t)))
567 (defun wl-message-button-dispatcher (event)
568 "Select the button under point."
570 (mouse-set-point event)
571 (let ((callback (get-text-property (point) 'wl-message-button-callback))
572 (data (get-text-property (point) 'wl-message-button-data)))
574 (funcall callback data)
575 (wl-message-button-dispatcher-internal event))))
577 (defun wl-message-button-refer-article (data)
578 "Read article specified by Message-ID DATA at point."
579 (switch-to-buffer-other-window
580 wl-message-buffer-cur-summary-buffer)
581 (if (wl-summary-jump-to-msg-by-message-id data)
582 (wl-summary-redisplay)))
584 (defun wl-message-refer-article-or-url (e)
585 "Read article specified by message-id around point.
586 If failed, attempt to execute button-dispatcher."
588 (let ((window (get-buffer-window (current-buffer)))
589 mouse-window point beg end msg-id)
593 (setq mouse-window (get-buffer-window (current-buffer)))
595 (setq beg (save-excursion (beginning-of-line) (point)))
596 (setq end (save-excursion (end-of-line) (point)))
597 (search-forward ">" end t) ;Move point to end of "<....>".
598 (if (and (re-search-backward "\\(<[^<> \t\n]+@[^<> \t\n]+>\\)"
600 (not (string-match "mailto:"
601 (setq msg-id (wl-match-buffer 1)))))
604 (switch-to-buffer-other-window
605 wl-message-buffer-cur-summary-buffer)
606 (if (wl-summary-jump-to-msg-by-message-id msg-id)
607 (wl-summary-redisplay)))
608 (wl-message-button-dispatcher-internal e)))
609 (if (eq mouse-window (get-buffer-window (current-buffer)))
610 (select-window window)))))
612 (defun wl-message-uu-substring (buf outbuf &optional first last)
615 (search-forward "\n\n")
617 ep filename case-fold-search)
621 (if (re-search-forward "^begin[ \t]+[0-9]+[ \t]+\\([^ ].*\\)" nil t)
622 (setq filename (buffer-substring (match-beginning 1)(match-end 1)))
624 (re-search-forward "^M.*$" nil t)) ; uuencoded string
627 (goto-char (point-max))
629 (re-search-backward "^end" sp t)
630 (re-search-backward "^M.*$" sp t)) ; uuencoded string
634 (goto-char (point-max))
635 (insert-buffer-substring buf sp ep)
639 ;;; wl-message.el ends here