2 ;;; tm-vm.el --- tm-MUA for VM
4 ;;; Copyright (C) 1994 MASUTANI Yasuhiro
5 ;;; Copyright (C) 1995 WAKAMIYA Kenji
6 ;;; Copyright (C) 1995,1996 KOBAYASHI Shuhei
7 ;;; Copyright (C) 1996 Oscar Figueiredo
9 ;;; Author: MASUTANI Yasuhiro <masutani@me.es.osaka-u.ac.jp>
10 ;;; Kenji Wakamiya <wkenji@flab.fujitsu.co.jp>
11 ;;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
12 ;;; KOBAYASHI Shuhei <shuhei-k@jaist.ac.jp>
13 ;;; Oscar Figueiredo <figueire@lspsun2.epfl.ch>
14 ;;; modified by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
15 ;;; ISHIHARA Akito <aki@bpel.tutics.tut.ac.jp>
16 ;;; Rob Kooper <kooper@cc.gatech.edu>
17 ;;; Maintainer: KOBAYASHI Shuhei <shuhei-k@jaist.ac.jp>
18 ;;; Created: 1994/10/29
19 ;;; Version: $Revision: 7.54 $
20 ;;; Keywords: mail, MIME, multimedia, multilingual, encoded-word
22 ;;; This file is part of tm (Tools for MIME).
24 ;;; This program is free software; you can redistribute it and/or
25 ;;; modify it under the terms of the GNU General Public License as
26 ;;; published by the Free Software Foundation; either version 2, or
27 ;;; (at your option) any later version.
29 ;;; This program is distributed in the hope that it will be useful,
30 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
31 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
32 ;;; General Public License for more details.
34 ;;; You should have received a copy of the GNU General Public License
35 ;;; along with This program. If not, write to the Free Software
36 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
40 ;;; Plese insert `(require 'tm-vm)' in your ~/.vm file.
47 (defconst tm-vm/RCS-ID
48 "$Id: tm-vm.el,v 7.54 1996/06/12 23:46:24 shuhei-k Exp $")
49 (defconst tm-vm/version (get-version-string tm-vm/RCS-ID))
51 (define-key vm-mode-map "Z" 'tm-vm/view-message)
52 (define-key vm-mode-map "T" 'tm-vm/decode-message-header)
53 (define-key vm-mode-map "\et" 'tm-vm/toggle-preview-mode)
55 (defvar tm-vm/use-original-url-button nil
56 "*If it is t, use original URL button instead of tm's.")
58 (defvar tm-vm-load-hook nil
59 "*List of functions called after tm-vm is loaded.")
62 ;;; @ for MIME encoded-words
65 (defvar tm-vm/use-tm-patch nil
66 "Does not decode encoded-words in summary buffer if it is t.
67 If you use tiny-mime patch for VM (by RIKITAKE Kenji
68 <kenji@reseau.toyonaka.osaka.jp>), please set it t [tm-vm.el]")
70 (or tm-vm/use-tm-patch
73 (defvar tm-vm/chop-full-name-function 'tm-vm/default-chop-full-name)
74 (setq vm-chop-full-name-function tm-vm/chop-full-name-function)
76 (defun tm-vm/default-chop-full-name (address)
77 (let* ((ret (vm-default-chop-full-name address))
80 (if (stringp full-name)
81 (cons (mime-eword/decode-string full-name)
86 (or (fboundp 'tm:vm-su-subject)
87 (fset 'tm:vm-su-subject (symbol-function 'vm-su-subject))
89 (defun vm-su-subject (m)
90 (mime-eword/decode-string (tm:vm-su-subject m))
93 (or (fboundp 'tm:vm-su-full-name)
94 (fset 'tm:vm-su-full-name (symbol-function 'vm-su-full-name))
96 (defun vm-su-full-name (m)
97 (mime-eword/decode-string (tm:vm-su-full-name m))
100 (or (fboundp 'tm:vm-su-to-names)
101 (fset 'tm:vm-su-to-names (symbol-function 'vm-su-to-names))
103 (defun vm-su-to-names (m)
104 (mime-eword/decode-string (tm:vm-su-to-names m))
109 (defun tm-vm/decode-message-header (&optional count)
110 "Decode MIME header of current message.
111 Numeric prefix argument COUNT means to decode the current message plus
112 the next COUNT-1 messages. A negative COUNT means decode the current
113 message and the previous COUNT-1 messages.
114 When invoked on marked messages (via vm-next-command-uses-marks),
115 all marked messages are affected, other messages are ignored."
117 (or count (setq count 1))
118 (vm-follow-summary-cursor)
119 (vm-select-folder-buffer)
120 (vm-check-for-killed-summary)
121 (vm-error-if-folder-empty)
122 (vm-error-if-folder-read-only)
123 (let ((mlist (vm-select-marked-or-prefixed-messages count))
129 (setq realm (vm-real-message-of (car mlist)))
130 ;; Go to real folder of this message.
131 ;; But maybe this message is already real message...
132 (set-buffer (vm-buffer-of realm))
133 (let ((buffer-read-only nil))
135 (narrow-to-region (vm-headers-of realm) (vm-text-of realm))
136 (mime/decode-message-header))
137 (let ((vm-message-pointer (list realm))
139 (vm-discard-cached-data))
140 ;; Mark each virtual and real message for later summary
142 (setq vlist (cons realm (vm-virtual-messages-of realm)))
144 (vm-mark-for-summary-update (car vlist))
145 ;; Remember virtual and real folders related this message,
146 ;; for later display update.
147 (or (memq (vm-buffer-of (car vlist)) vbufs)
148 (setq vbufs (cons (vm-buffer-of (car vlist)) vbufs)))
149 (setq vlist (cdr vlist)))
150 (if (eq vm-flush-interval t)
151 (vm-stuff-virtual-attributes realm)
152 (vm-set-modflag-of realm t)))
153 (setq mlist (cdr mlist)))
154 ;; Update mail-buffers and summaries.
156 (set-buffer (car vbufs))
157 (vm-preview-current-message)
158 (setq vbufs (cdr vbufs))))))
161 ;;; @ automatic MIME preview
164 (defvar tm-vm/automatic-mime-preview t
165 "*If non-nil, show MIME processed article.")
167 (defvar tm-vm/strict-mime t
168 "*If nil, do MIME processing even if there is not MIME-Version field.")
170 (defvar tm-vm/select-message-hook nil
171 "*List of functions called every time a message is selected.
172 tm-vm uses `vm-select-message-hook', use this hook instead.")
174 (defvar tm-vm/system-state nil)
175 (defun tm-vm/system-state ()
177 (if mime::preview/article-buffer
178 (set-buffer mime::preview/article-buffer)
179 (vm-select-folder-buffer))
182 (defun tm-vm/display-preview-buffer ()
183 (let* ((mbuf (current-buffer))
184 (mwin (vm-get-visible-buffer-window mbuf))
185 (pbuf (and mime::article/preview-buffer
186 (get-buffer mime::article/preview-buffer)))
187 (pwin (and pbuf (vm-get-visible-buffer-window pbuf))))
188 (if (and pbuf (tm-vm/system-state))
189 ;; display preview buffer
192 (vm-undisplay-buffer mbuf)
193 (tm-vm/show-current-message))
194 ((and mwin (not pwin))
195 (set-window-buffer mwin pbuf)
196 (tm-vm/show-current-message))
198 (tm-vm/show-current-message))
200 ;; don't display if neither mwin nor pwin was displayed before.
202 ;; display folder buffer
205 (vm-undisplay-buffer pbuf))
206 ((and (not mwin) pwin)
207 (set-window-buffer pwin mbuf))
209 ;; folder buffer is already displayed.
212 ;; don't display if neither mwin nor pwin was displayed before.
216 (defun tm-vm/preview-current-message ()
217 ;; assumed current buffer is folder buffer.
218 (setq tm-vm/system-state nil)
219 (if (get-buffer mime/output-buffer-name)
220 (vm-undisplay-buffer mime/output-buffer-name))
221 (if (and vm-message-pointer tm-vm/automatic-mime-preview)
222 (if (or (not tm-vm/strict-mime)
223 (vm-get-header-contents (car vm-message-pointer)
225 ;; do MIME processiong.
227 (set (make-local-variable 'tm-vm/system-state) 'previewing)
228 (save-window-excursion
230 (goto-char (point-max))
232 (narrow-to-region (point)
235 (vm-start-of (car vm-message-pointer))
241 (if (and tm-vm/use-original-url-button
242 vm-use-menus (vm-menu-support-possible-p))
244 ;; 1996/2/16, fixed by
245 ;; Oscar Figueiredo <figueire@lspsun2.epfl.ch>
246 ;; Highlight message (and display XFace if supported)
247 (if (or vm-highlighted-header-regexp
248 (and (vm-xemacs-p) vm-use-lucid-highlighting))
249 (vm-highlight-headers))
251 (goto-char (point-min))
252 (narrow-to-region (point) (search-forward "\n\n" nil t))
254 ;; don't do MIME processing. decode header only.
255 (let (buffer-read-only)
256 (mime/decode-message-header))
258 ;; don't preview; do nothing.
260 (tm-vm/display-preview-buffer)
261 (run-hooks 'tm-vm/select-message-hook))
263 (defun tm-vm/show-current-message ()
264 (if mime::preview/article-buffer
265 (set-buffer mime::preview/article-buffer)
266 (vm-select-folder-buffer))
267 ;; Now current buffer is folder buffer.
268 (if (or t ; mime/viewer-mode doesn't support narrowing yet.
269 (null vm-preview-lines)
270 (and (not vm-preview-read-messages)
272 (car vm-message-pointer)))
274 (car vm-message-pointer)))))
276 (set-buffer mime::article/preview-buffer)
279 (goto-char (point-min))
281 ;; narrow to page; mime/viewer-mode doesn't support narrowing yet.
283 (if (vm-get-visible-buffer-window mime::article/preview-buffer)
285 (setq tm-vm/system-state 'reading)
286 (if (vm-new-flag (car vm-message-pointer))
287 (vm-set-new-flag (car vm-message-pointer) nil))
288 (if (vm-unread-flag (car vm-message-pointer))
289 (vm-set-unread-flag (car vm-message-pointer) nil))
290 (vm-update-summary-and-mode-line)
292 (vm-update-summary-and-mode-line)))
294 (defun tm-vm/toggle-preview-mode ()
296 (vm-select-folder-buffer)
297 (vm-display (current-buffer) t (list this-command)
298 (list this-command 'reading-message))
299 (if tm-vm/automatic-mime-preview
300 (setq tm-vm/automatic-mime-preview nil
301 tm-vm/system-state nil)
302 (setq tm-vm/automatic-mime-preview t
303 tm-vm/system-state nil)
306 (let* ((mp (car vm-message-pointer))
307 (exposed (= (point-min) (vm-start-of mp))))
308 (if (or (not tm-vm/strict-mime)
309 (vm-get-header-contents mp "MIME-Version:"))
310 ;; do MIME processiong.
312 (set (make-local-variable 'tm-vm/system-state) 'previewing)
313 (save-window-excursion
315 (goto-char (point-min))
316 (narrow-to-region (point)
317 (search-forward "\n\n" nil t))
319 ;; don't do MIME processing. decode header only.
320 (let (buffer-read-only)
321 (mime/decode-message-header))
323 ;; don't preview; do nothing.
325 (tm-vm/display-preview-buffer)
328 (add-hook 'vm-select-message-hook 'tm-vm/preview-current-message)
329 (add-hook 'vm-visit-folder-hook 'tm-vm/preview-current-message)
331 ;;; tm-vm move commands
334 (defmacro tm-vm/save-window-excursion (&rest forms)
335 (list 'let '((tm-vm/selected-window (selected-window)))
336 (list 'unwind-protect
338 '(if (window-live-p tm-vm/selected-window)
339 (select-window tm-vm/selected-window)))))
341 ;;; based on vm-scroll-forward [vm-page.el]
342 (defun tm-vm/scroll-forward (&optional arg)
344 (let ((this-command 'vm-scroll-forward))
345 (if (not (tm-vm/system-state))
346 (vm-scroll-forward arg)
347 (let* ((mp-changed (vm-follow-summary-cursor))
348 (mbuf (or (vm-select-folder-buffer) (current-buffer)))
349 (mwin (vm-get-buffer-window mbuf))
350 (pbuf (and mime::article/preview-buffer
351 (get-buffer mime::article/preview-buffer)))
352 (pwin (and pbuf (vm-get-buffer-window pbuf)))
353 (was-invisible (and (null mwin) (null pwin)))
355 ;; now current buffer is folder buffer.
356 (tm-vm/save-window-excursion
357 (if (or mp-changed was-invisible)
358 (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
359 (list this-command 'reading-message)))
360 (tm-vm/display-preview-buffer)
361 (setq mwin (vm-get-buffer-window mbuf)
362 pwin (and pbuf (vm-get-buffer-window pbuf)))
364 ((or mp-changed was-invisible)
368 ;; preview buffer is killed.
369 (tm-vm/preview-current-message)
370 (vm-update-summary-and-mode-line))
371 ((eq (tm-vm/system-state) 'previewing)
372 (tm-vm/show-current-message))
376 (if (pos-visible-in-window-p (point-max) pwin)
378 ;; not end of message. scroll preview buffer only.
385 ;;; based on vm-scroll-backward [vm-page.el]
386 (defun tm-vm/scroll-backward (&optional arg)
388 (let ((this-command 'vm-scroll-backward))
389 (if (not (tm-vm/system-state))
390 (vm-scroll-backward arg)
391 (let* ((mp-changed (vm-follow-summary-cursor))
392 (mbuf (or (vm-select-folder-buffer) (current-buffer)))
393 (mwin (vm-get-buffer-window mbuf))
394 (pbuf (and mime::article/preview-buffer
395 (get-buffer mime::article/preview-buffer)))
396 (pwin (and pbuf (vm-get-buffer-window pbuf)))
397 (was-invisible (and (null mwin) (null pwin)))
399 ;; now current buffer is folder buffer.
400 (if (or mp-changed was-invisible)
401 (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
402 (list this-command 'reading-message)))
403 (tm-vm/save-window-excursion
404 (tm-vm/display-preview-buffer)
405 (setq mwin (vm-get-buffer-window mbuf)
406 pwin (and pbuf (vm-get-buffer-window pbuf)))
412 ;; preview buffer is killed.
413 (tm-vm/preview-current-message)
414 (vm-update-summary-and-mode-line))
415 ((eq (tm-vm/system-state) 'previewing)
416 (tm-vm/show-current-message))
420 (if (pos-visible-in-window-p (point-min) pwin)
422 ;; scroll preview buffer only.
428 ;;; based on vm-beginning-of-message [vm-page.el]
429 (defun tm-vm/beginning-of-message ()
430 "Moves to the beginning of the current message."
432 (if (not (tm-vm/system-state))
434 (setq this-command 'vm-beginning-of-message)
435 (vm-beginning-of-message))
436 (vm-follow-summary-cursor)
437 (vm-select-folder-buffer)
438 (vm-check-for-killed-summary)
439 (vm-error-if-folder-empty)
440 (let ((mbuf (current-buffer))
441 (pbuf (and mime::article/preview-buffer
442 (get-buffer mime::article/preview-buffer))))
445 (tm-vm/preview-current-message)
446 (setq pbuf (get-buffer mime::article/preview-buffer))
448 (vm-display mbuf t '(vm-beginning-of-message)
449 '(vm-beginning-of-message reading-message))
450 (tm-vm/display-preview-buffer)
452 (tm-vm/save-window-excursion
453 (select-window (vm-get-buffer-window pbuf))
455 (goto-char (point-min))
458 ;;; based on vm-end-of-message [vm-page.el]
459 (defun tm-vm/end-of-message ()
460 "Moves to the end of the current message."
462 (if (not (tm-vm/system-state))
464 (setq this-command 'vm-end-of-message)
466 (vm-follow-summary-cursor)
467 (vm-select-folder-buffer)
468 (vm-check-for-killed-summary)
469 (vm-error-if-folder-empty)
470 (let ((mbuf (current-buffer))
471 (pbuf (and mime::article/preview-buffer
472 (get-buffer mime::article/preview-buffer))))
475 (tm-vm/preview-current-message)
476 (setq pbuf (get-buffer mime::article/preview-buffer))
478 (vm-display mbuf t '(vm-end-of-message)
479 '(vm-end-of-message reading-message))
480 (tm-vm/display-preview-buffer)
482 (tm-vm/save-window-excursion
483 (select-window (vm-get-buffer-window pbuf))
485 (goto-char (point-max))
488 ;;; based on vm-howl-if-eom [vm-page.el]
489 (defun tm-vm/howl-if-eom ()
490 (let* ((pbuf (or mime::article/preview-buffer (current-buffer)))
491 (pwin (and (vm-get-visible-buffer-window pbuf))))
494 (save-window-excursion
496 (let ((next-screen-context-lines 0))
499 (save-window-excursion
500 (let ((scroll-in-place-replace-original nil))
504 (tm-vm/emit-eom-blurb)
507 ;;; based on vm-emit-eom-blurb [vm-page.el]
508 (defun tm-vm/emit-eom-blurb ()
510 (if mime::preview/article-buffer
511 (set-buffer mime::preview/article-buffer))
512 (vm-emit-eom-blurb)))
514 ;;; based on vm-quit [vm-folder.el]
518 (vm-select-folder-buffer)
519 (if (and mime::article/preview-buffer
520 (get-buffer mime::article/preview-buffer))
521 (kill-buffer mime::article/preview-buffer)))
524 (substitute-key-definition 'vm-scroll-forward
525 'tm-vm/scroll-forward vm-mode-map)
526 (substitute-key-definition 'vm-scroll-backward
527 'tm-vm/scroll-backward vm-mode-map)
528 (substitute-key-definition 'vm-beginning-of-message
529 'tm-vm/beginning-of-message vm-mode-map)
530 (substitute-key-definition 'vm-end-of-message
531 'tm-vm/end-of-message vm-mode-map)
532 (substitute-key-definition 'vm-quit
533 'tm-vm/quit vm-mode-map)
535 ;;; based on vm-next-message [vm-motion.el]
536 (defun tm-vm/next-message ()
537 (set-buffer mime::preview/article-buffer)
538 (let ((this-command 'vm-next-message)
539 (owin (selected-window))
540 (vm-preview-lines nil)
542 (vm-next-message 1 nil t)
543 (if (window-live-p owin)
544 (select-window owin))))
546 ;;; based on vm-previous-message [vm-motion.el]
547 (defun tm-vm/previous-message ()
548 (set-buffer mime::preview/article-buffer)
549 (let ((this-command 'vm-previous-message)
550 (owin (selected-window))
551 (vm-preview-lines nil)
553 (vm-previous-message 1 nil t)
554 (if (window-live-p owin)
555 (select-window owin))))
557 (set-alist 'mime-viewer/over-to-previous-method-alist
558 'vm-mode 'tm-vm/previous-message)
559 (set-alist 'mime-viewer/over-to-next-method-alist
560 'vm-mode 'tm-vm/next-message)
561 (set-alist 'mime-viewer/over-to-previous-method-alist
562 'vm-virtual-mode 'tm-vm/previous-message)
563 (set-alist 'mime-viewer/over-to-next-method-alist
564 'vm-virtual-mode 'tm-vm/next-message)
566 ;;; @@ vm-yank-message
568 ;; 1996/3/28 by Oscar Figueiredo <figueire@lspsun16.epfl.ch>
572 (defun vm-yank-message (&optional message)
573 "Yank message number N into the current buffer at point.
574 When called interactively N is always read from the minibuffer. When
575 called non-interactively the first argument is expected to be a
578 This function originally provided by vm-reply has been patched for TM in
579 order to provide better citation of MIME messages : if a MIME Preview
580 buffer is displayed for the message then its contents are inserted
581 instead of the raw message.
583 This command is meant to be used in VM created Mail mode buffers; the
584 yanked message comes from the mail buffer containing the message you
585 are replying to, forwarding, or invoked VM's mail command from.
587 All message headers are yanked along with the text. Point is
588 left before the inserted text, the mark after. Any hook
589 functions bound to mail-citation-hook are run, after inserting
590 the text and setting point and mark. For backward compatibility,
591 if mail-citation-hook is set to nil, `mail-yank-hooks' is run
594 If mail-citation-hook and mail-yank-hooks are both nil, this
595 default action is taken: the yanked headers are trimmed as
596 specified by vm-included-text-headers and
597 vm-included-text-discard-header-regexp, and the value of
598 vm-included-text-prefix is prepended to every yanked line."
601 ;; What we really want for the first argument is a message struct,
602 ;; but if called interactively, we let the user type in a message
607 (last-command last-command)
608 (this-command this-command))
609 (if (bufferp vm-mail-buffer)
611 (vm-select-folder-buffer)
612 (setq default (and vm-message-pointer
613 (vm-number-of (car vm-message-pointer)))
615 (format "Yank message number: (default %s) "
617 "Yank message number: "))
618 (while (zerop result)
619 (setq result (read-string prompt))
620 (and (string= result "") default (setq result default))
621 (setq result (string-to-int result)))
622 (if (null (setq mp (nthcdr (1- result) vm-message-list)))
623 (error "No such message."))
627 (if mail-reply-buffer
629 (error "This is not a VM Mail mode buffer."))
630 (if (null (buffer-name vm-mail-buffer))
631 (error "The folder buffer containing message %d has been killed."
632 (vm-number-of message)))
633 (vm-display nil nil '(vm-yank-message)
634 '(vm-yank-message composing-message))
635 (setq message (vm-real-message-of message))
636 (let ((b (current-buffer)) (start (point)) end)
640 (set-buffer (vm-buffer-of message))
641 (let* ((mbuf (current-buffer))
642 (pbuf (and mime::article/preview-buffer
643 (get-buffer mime::article/preview-buffer)))
644 (pwin (and pbuf (vm-get-visible-buffer-window pbuf))))
647 (let ((tmp (generate-new-buffer "tm-vm/tmp")))
649 (append-to-buffer tmp (point-min) (point-max))
652 '(lambda (ext maparg)
653 (set-extent-property ext 'begin-glyph nil)))
654 (append-to-buffer b (point-min) (point-max))
656 (+ start (length (buffer-string))) b))
659 (append-to-buffer b (point-min) (point-max))
661 (+ start (length (buffer-string))) b)))
665 b (vm-headers-of message) (vm-text-end-of message))
667 (vm-marker (+ start (- (vm-text-end-of message)
668 (vm-headers-of message))) b))))))
670 (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
671 (mail-yank-hooks (run-hooks 'mail-yank-hooks))
672 (t (vm-mail-yank-default message)))
680 ;;; based on vm-do-reply [vm-reply.el]
681 (defun tm-vm/do-reply (buf to-all include-text)
684 (let ((dir default-directory)
685 to cc subject mp in-reply-to references newsgroups)
687 (let ((reply-to (rfc822/get-field-body "Reply-To")))
688 (if (vm-ignored-reply-to reply-to)
691 ((setq to (rfc822/get-field-body "From")))
692 ;; (t (error "No From: or Reply-To: header in message"))
695 (setq cc (delq nil (cons cc (rfc822/get-field-bodies '("To" "Cc"))))
696 cc (mapconcat 'identity cc ","))
698 (setq subject (rfc822/get-field-body "Subject"))
699 (and subject vm-reply-subject-prefix
700 (let ((case-fold-search t))
703 (string-match (regexp-quote vm-reply-subject-prefix)
706 (setq subject (concat vm-reply-subject-prefix subject)))
707 (setq in-reply-to (rfc822/get-field-body "Message-Id")
709 (rfc822/get-field-bodies '("References" "In-Reply-To"))
711 newsgroups (list (or (and to-all
712 (rfc822/get-field-body "Followup-To"))
713 (rfc822/get-field-body "Newsgroups"))))
714 (setq to (vm-parse-addresses to)
715 cc (vm-parse-addresses cc))
716 (if vm-reply-ignored-addresses
717 (setq to (vm-strip-ignored-addresses to)
718 cc (vm-strip-ignored-addresses cc)))
719 (setq to (vm-delete-duplicates to nil t))
720 (setq cc (vm-delete-duplicates
721 (append (vm-delete-duplicates cc nil t)
722 to (copy-sequence to))
724 (and to (setq to (mapconcat 'identity to ",\n ")))
725 (and cc (setq cc (mapconcat 'identity cc ",\n ")))
726 (and (null to) (setq to cc cc nil))
727 (setq references (delq nil references)
728 references (mapconcat 'identity references " ")
729 references (vm-parse references "[^<]*\\(<[^>]+>\\)")
730 references (vm-delete-duplicates references)
731 references (if references (mapconcat 'identity references "\n\t")))
732 (setq newsgroups (delq nil newsgroups)
733 newsgroups (mapconcat 'identity newsgroups ",")
734 newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
735 newsgroups (vm-delete-duplicates newsgroups)
736 newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
739 (format "reply to %s%s"
740 (rfc822/full-name-string
741 (car (rfc822/parse-address
742 (rfc822/lexical-analyze to))))
744 to subject in-reply-to cc references newsgroups)
745 (setq mail-reply-buffer buf
746 ;; vm-system-state 'replying
747 default-directory dir))
750 (goto-char (point-min))
751 (let ((case-fold-search nil))
753 (concat "^" (regexp-quote mail-header-separator) "$") nil 0))
755 (tm-vm/yank-content)))
756 (run-hooks 'vm-reply-hook)
757 (run-hooks 'vm-mail-mode-hook)
760 (defun tm-vm/following-method (buf)
761 (tm-vm/do-reply buf 'to-all 'include-text)
764 (defun tm-vm/yank-content ()
766 (let ((this-command 'vm-yank-message))
767 (vm-display nil nil '(vm-yank-message)
768 '(vm-yank-message composing-message))
770 (narrow-to-region (point)(point))
771 (insert-buffer mail-reply-buffer)
772 (goto-char (point-max))
774 (goto-char (point-min)))
775 (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
776 (mail-yank-hooks (run-hooks 'mail-yank-hooks))
777 (t (mail-indent-citation)))
780 (set-alist 'mime-viewer/following-method-alist
782 (function tm-vm/following-method))
783 (set-alist 'mime-viewer/following-method-alist
785 (function tm-vm/following-method))
788 (defun tm-vm/quit-view-message ()
789 "Quit MIME-viewer and go back to VM.
790 This function is called by `mime-viewer/quit' command via
791 `mime-viewer/quitting-method-alist'."
792 (if (get-buffer mime/output-buffer-name)
793 (vm-undisplay-buffer mime/output-buffer-name))
794 (if (and tm-vm/automatic-mime-preview
796 (set-buffer mime::preview/article-buffer)
798 (switch-to-buffer mime::preview/article-buffer)
799 (mime-viewer/kill-buffer)
800 (vm-select-folder-buffer)
801 (setq tm-vm/system-state nil))
802 (vm-display (current-buffer) t (list this-command)
803 (list this-command 'reading-message))
804 (tm-vm/display-preview-buffer)
807 (defun tm-vm/view-message ()
808 "Decode and view MIME encoded message, under VM."
810 (vm-follow-summary-cursor)
811 (vm-select-folder-buffer)
812 (vm-check-for-killed-summary)
813 (vm-error-if-folder-empty)
814 (vm-display (current-buffer) t '(tm-vm/view-message)
815 '(tm-vm/view-mesage reading-message))
816 (let* ((mp (car vm-message-pointer))
817 (ct (vm-get-header-contents mp "Content-Type:"))
818 (cte (vm-get-header-contents mp "Content-Transfer-Encoding:"))
819 (exposed (= (point-min) (vm-start-of mp))))
822 ;; vm-widen-page hides exposed header if pages are delimited.
823 ;; So, here we expose it again.
825 (narrow-to-region (vm-start-of mp) (point-max)))
826 (select-window (vm-get-buffer-window (current-buffer)))
827 (mime/viewer-mode nil
828 (mime/parse-Content-Type (or ct ""))
832 (set-alist 'mime-viewer/quitting-method-alist
834 'tm-vm/quit-view-message)
836 (set-alist 'mime-viewer/quitting-method-alist
838 'tm-vm/quit-view-message)
848 (set-atype 'mime/content-decoding-condition
849 '((type . "message/partial")
850 (method . mime-article/grab-message/partials)
851 (major-mode . vm-mode)
852 (summary-buffer-exp . vm-summary-buffer)
854 (set-alist 'tm-partial/preview-article-method-alist
866 ;;; @@ for multipart/digest
869 (defvar tm-vm/forward-message-hook nil
870 "*List of functions called after a Mail mode buffer has been
871 created to forward a message in message/rfc822 type format.
872 If `vm-forwarding-digest-type' is \"rfc1521\", tm-vm runs this
873 hook instead of `vm-forward-message-hook'.")
875 (defvar tm-vm/send-digest-hook nil
876 "*List of functions called after a Mail mode buffer has been
877 created to send a digest in multipart/digest type format.
878 If `vm-digest-send-type' is \"rfc1521\", tm-vm runs this hook
879 instead of `vm-send-digest-hook'.")
881 (defun tm-vm/enclose-messages (mlist &optional preamble)
882 "Enclose the messages in MLIST as multipart/digest.
883 The resulting digest is inserted at point in the current buffer.
885 MLIST should be a list of message structs (real or virtual).
886 These are the messages that will be enclosed."
888 (let ((digest (consp (cdr mlist)))
892 (narrow-to-region (point) (point))
894 (setq m (vm-real-message-of (car mlist)))
895 (mime-editor/insert-tag "message" "rfc822")
896 (tm-mail/insert-message m)
897 (goto-char (point-max))
898 (setq mlist (cdr mlist)))
901 (goto-char (point-min))
902 (mime-editor/insert-tag "text" "plain")
903 (vm-unsaved-message "Building digest preamble...")
905 (let ((vm-summary-uninteresting-senders nil))
907 (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n"))
908 (if vm-digest-center-preamble
913 (setq mp (cdr mp)))))
915 (mime-editor/enclose-digest-region (point-min) (point-max)))
918 (defun tm-vm/forward-message ()
919 "Forward the current message to one or more recipients.
920 You will be placed in a Mail mode buffer as you would with a
921 reply, but you must fill in the To: header and perhaps the
922 Subject: header manually."
924 (if (not (equal vm-forwarding-digest-type "rfc1521"))
926 (vm-follow-summary-cursor)
927 (vm-select-folder-buffer)
928 (vm-check-for-killed-summary)
929 (vm-error-if-folder-empty)
930 (if (eq last-command 'vm-next-command-uses-marks)
931 (let ((vm-digest-send-type vm-forwarding-digest-type))
932 (setq this-command 'vm-next-command-uses-marks)
933 (command-execute 'tm-vm/send-digest))
934 (let ((dir default-directory)
935 (mp vm-message-pointer))
939 (format "forward of %s's note re: %s"
940 (vm-su-full-name (car vm-message-pointer))
941 (vm-su-subject (car vm-message-pointer)))
943 (and vm-forwarding-subject-format
944 (let ((vm-summary-uninteresting-senders nil))
945 (vm-sprintf 'vm-forwarding-subject-format (car mp)))))
946 (make-local-variable 'vm-forward-list)
947 (setq vm-system-state 'forwarding
948 vm-forward-list (list (car mp))
949 default-directory dir)
950 (goto-char (point-min))
952 (concat "^" (regexp-quote mail-header-separator) "\n") nil 0)
953 (tm-vm/enclose-messages vm-forward-list)
954 (mail-position-on-field "To"))
955 (run-hooks 'tm-vm/forward-message-hook)
956 (run-hooks 'vm-mail-mode-hook)))))
958 (defun tm-vm/send-digest (&optional arg)
959 "Send a digest of all messages in the current folder to recipients.
960 The type of the digest is specified by the variable vm-digest-send-type.
961 You will be placed in a Mail mode buffer as is usual with replies, but you
962 must fill in the To: and Subject: headers manually.
964 If invoked on marked messages (via vm-next-command-uses-marks),
965 only marked messages will be put into the digest."
967 (if (not (equal vm-digest-send-type "rfc1521"))
969 (vm-select-folder-buffer)
970 (vm-check-for-killed-summary)
971 (vm-error-if-folder-empty)
972 (let ((dir default-directory)
973 (vm-forward-list (if (eq last-command 'vm-next-command-uses-marks)
974 (vm-select-marked-or-prefixed-messages 0)
979 (vm-mail-internal (format "digest from %s" (buffer-name)))
980 (setq vm-system-state 'forwarding
981 default-directory dir)
982 (goto-char (point-min))
983 (re-search-forward (concat "^" (regexp-quote mail-header-separator)
985 (goto-char (match-end 0))
986 (vm-unsaved-message "Building %s digest..." vm-digest-send-type)
987 (tm-vm/enclose-messages vm-forward-list arg)
988 (mail-position-on-field "To")
989 (message "Building %s digest... done" vm-digest-send-type)))
990 (run-hooks 'tm-vm/send-digest-hook)
991 (run-hooks 'vm-mail-mode-hook)))
993 (substitute-key-definition 'vm-forward-message
994 'tm-vm/forward-message vm-mode-map)
995 (substitute-key-definition 'vm-send-digest
996 'tm-vm/send-digest vm-mode-map)
1002 (defvar tm-vm/use-xemacs-popup-menu t)
1004 ;;; modified by Steven L. Baur <steve@miranova.com>
1005 ;;; 1995/12/6 (c.f. [tm-en:209])
1006 (defun mime-editor/attach-to-vm-mode-menu ()
1007 "Arrange to attach MIME editor's popup menu to VM's"
1008 (if (boundp 'vm-menu-mail-menu)
1010 (setq vm-menu-mail-menu
1011 (append vm-menu-mail-menu
1013 mime-editor/popup-menu-for-xemacs)))
1014 (remove-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu)
1021 (autoload 'tm-mail/insert-message "tm-mail")
1022 (set-alist 'mime-editor/message-inserter-alist
1023 'mail-mode (function tm-mail/insert-message))
1024 (set-alist 'mime-editor/split-message-sender-alist
1025 'mail-mode (function
1030 (if (and (string-match "XEmacs\\|Lucid" emacs-version)
1031 tm-vm/use-xemacs-popup-menu)
1032 (add-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu)
1040 (setq vm-forwarding-digest-type "rfc1521")
1041 (setq vm-digest-send-type "rfc1521")
1054 (or (fboundp 'tm:bbdb/vm-update-record)
1055 (fset 'tm:bbdb/vm-update-record
1056 (symbol-function 'bbdb/vm-update-record)))
1057 (defun bbdb/vm-update-record (&optional offer-to-create)
1058 (vm-select-folder-buffer)
1059 (if (and (tm-vm/system-state)
1060 mime::article/preview-buffer
1061 (get-buffer mime::article/preview-buffer))
1062 (tm-bbdb/update-record offer-to-create)
1063 (tm:bbdb/vm-update-record offer-to-create)
1065 (remove-hook 'vm-select-message-hook 'bbdb/vm-update-record)
1066 (remove-hook 'vm-show-message-hook 'bbdb/vm-update-record)
1067 (add-hook 'tm-vm/select-message-hook 'bbdb/vm-update-record)
1076 (run-hooks 'tm-vm-load-hook)
1078 ;;; tm-vm.el ends here.