;;; tm-vm.el --- tm-MUA (MIME Extension module) for VM

;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc.

;; Author: MASUTANI Yasuhiro <masutani@me.es.osaka-u.ac.jp>
;;         Kenji Wakamiya <wkenji@flab.fujitsu.co.jp>
;;         MORIOKA Tomohiko <morioka@jaist.ac.jp>
;;         Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
;;         Oscar Figueiredo <figueire@lspsun2.epfl.ch>
;; Maintainer: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
;; Created: 1994/10/29
;; Version: $Revision: 7.62 $
;; Keywords: mail, MIME, multimedia, multilingual, encoded-word

;; This file is part of tm (Tools for MIME).

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or (at
;; your option) any later version.

;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;	Plese insert `(require 'tm-vm)' in your ~/.vm file.

;;; Code:

(require 'tm-view)
(require 'vm)

(defconst tm-vm/RCS-ID
  "$Id: tm-vm.el,v 7.62 1996/08/31 14:24:35 morioka Exp $")
(defconst tm-vm/version (get-version-string tm-vm/RCS-ID))

(define-key vm-mode-map "Z" 'tm-vm/view-message)
(define-key vm-mode-map "T" 'tm-vm/decode-message-header)
(define-key vm-mode-map "\et" 'tm-vm/toggle-preview-mode)

(defvar tm-vm/use-original-url-button nil
  "*If it is t, use original URL button instead of tm's.")

(defvar tm-vm-load-hook nil
  "*List of functions called after tm-vm is loaded.")


;;; @ for MIME encoded-words
;;;

(defvar tm-vm/use-tm-patch nil
  "Does not decode encoded-words in summary buffer if it is t.
If you use tiny-mime patch for VM (by RIKITAKE Kenji
<kenji@reseau.toyonaka.osaka.jp>), please set it t [tm-vm.el]")

(or tm-vm/use-tm-patch
    (progn
;;;
(defvar tm-vm/chop-full-name-function 'tm-vm/default-chop-full-name)
(setq vm-chop-full-name-function tm-vm/chop-full-name-function)

(defun tm-vm/default-chop-full-name (address)
  (let* ((ret (vm-default-chop-full-name address))
	 (full-name (car ret))
	 )
    (if (stringp full-name)
	(cons (mime-eword/decode-string full-name)
	      (cdr ret))
      ret)))

(require 'vm-summary)
(or (fboundp 'tm:vm-su-subject)
    (fset 'tm:vm-su-subject (symbol-function 'vm-su-subject))
    )
(defun vm-su-subject (m)
  (mime-eword/decode-string (tm:vm-su-subject m))
  )

(or (fboundp 'tm:vm-su-full-name)
    (fset 'tm:vm-su-full-name (symbol-function 'vm-su-full-name))
    )
(defun vm-su-full-name (m)
  (mime-eword/decode-string (tm:vm-su-full-name m))
  )

(or (fboundp 'tm:vm-su-to-names)
    (fset 'tm:vm-su-to-names (symbol-function 'vm-su-to-names))
    )
(defun vm-su-to-names (m)
  (mime-eword/decode-string (tm:vm-su-to-names m))
  )
;;;
))

(defun tm-vm/decode-message-header (&optional count)
  "Decode MIME header of current message.
Numeric prefix argument COUNT means to decode the current message plus
the next COUNT-1 messages.  A negative COUNT means decode the current
message and the previous COUNT-1 messages.
When invoked on marked messages (via vm-next-command-uses-marks),
all marked messages are affected, other messages are ignored."
  (interactive "p")
  (or count (setq count 1))
  (vm-follow-summary-cursor)
  (vm-select-folder-buffer)
  (vm-check-for-killed-summary)
  (vm-error-if-folder-empty)
  (vm-error-if-folder-read-only)
  (let ((mlist (vm-select-marked-or-prefixed-messages count))
	(realm nil)
	(vlist nil)
	(vbufs nil))
    (save-excursion
      (while mlist
	(setq realm (vm-real-message-of (car mlist)))
	;; Go to real folder of this message.
	;; But maybe this message is already real message...
	(set-buffer (vm-buffer-of realm))
	(let ((buffer-read-only nil))
	  (vm-save-restriction
	   (narrow-to-region (vm-headers-of realm) (vm-text-of realm))
	   (mime/decode-message-header))
	  (let ((vm-message-pointer (list realm))
		(last-command nil))
	    (vm-discard-cached-data))
	  ;; Mark each virtual and real message for later summary
	  ;; update.
	  (setq vlist (cons realm (vm-virtual-messages-of realm)))
	  (while vlist
	    (vm-mark-for-summary-update (car vlist))
	    ;; Remember virtual and real folders related this message,
	    ;; for later display update.
	    (or (memq (vm-buffer-of (car vlist)) vbufs)
		(setq vbufs (cons (vm-buffer-of (car vlist)) vbufs)))
	    (setq vlist (cdr vlist)))
	  (if (eq vm-flush-interval t)
	      (vm-stuff-virtual-attributes realm)
	    (vm-set-modflag-of realm t)))
	(setq mlist (cdr mlist)))
      ;; Update mail-buffers and summaries.
      (while vbufs
	(set-buffer (car vbufs))
	(vm-preview-current-message)
	(setq vbufs (cdr vbufs))))))


;;; @ automatic MIME preview
;;;

(defvar tm-vm/automatic-mime-preview t
  "*If non-nil, show MIME processed article.")

(defvar tm-vm/strict-mime t
  "*If nil, do MIME processing even if there is not MIME-Version field.")

(defvar tm-vm/select-message-hook nil
  "*List of functions called every time a message is selected.
tm-vm uses `vm-select-message-hook', use this hook instead.")

(defvar tm-vm/system-state nil)
(defun tm-vm/system-state ()
  (save-excursion
    (if mime::preview/article-buffer
        (set-buffer mime::preview/article-buffer)
      (vm-select-folder-buffer))
    tm-vm/system-state))

(defun tm-vm/display-preview-buffer ()
  (let* ((mbuf (current-buffer))
         (mwin (vm-get-visible-buffer-window mbuf))
         (pbuf (and mime::article/preview-buffer
                    (get-buffer mime::article/preview-buffer)))
         (pwin (and pbuf (vm-get-visible-buffer-window pbuf)))) 
    (if (and pbuf (tm-vm/system-state))
        ;; display preview buffer
        (cond
         ((and mwin pwin)
          (vm-undisplay-buffer mbuf)
          (tm-vm/show-current-message))
         ((and mwin (not pwin))
          (set-window-buffer mwin pbuf)
          (tm-vm/show-current-message))
         (pwin
          (tm-vm/show-current-message))
         (t
          ;; don't display if neither mwin nor pwin was displayed before.
          ))
      ;; display folder buffer
      (cond
       ((and mwin pwin)
        (vm-undisplay-buffer pbuf))
       ((and (not mwin) pwin)
        (set-window-buffer pwin mbuf))
       (mwin
        ;; folder buffer is already displayed.
        )
       (t
        ;; don't display if neither mwin nor pwin was displayed before.
        )))
    (set-buffer mbuf)))

(defun tm-vm/preview-current-message ()
  ;; assumed current buffer is folder buffer.
  (setq tm-vm/system-state nil)
  (if (get-buffer mime/output-buffer-name)
      (vm-undisplay-buffer mime/output-buffer-name))
  (if (and vm-message-pointer tm-vm/automatic-mime-preview)
      (if (or (not tm-vm/strict-mime)
              (vm-get-header-contents (car vm-message-pointer)
                                      "MIME-Version:"))
          ;; do MIME processiong.
          (progn
            (set (make-local-variable 'tm-vm/system-state) 'previewing)
            (save-window-excursion
	      (vm-widen-page)
	      (goto-char (point-max))
	      (widen)
	      (narrow-to-region (point)
				(save-excursion
				  (goto-char
				   (vm-start-of (car vm-message-pointer))
				   )
				  (forward-line)
				  (point)
				  ))
	      (mime/viewer-mode)
 	      (if (and tm-vm/use-original-url-button
		       vm-use-menus (vm-menu-support-possible-p))
 		  (vm-energize-urls))
	      ;; 1996/2/16, fixed by
	      ;;    Oscar Figueiredo <figueire@lspsun2.epfl.ch>
	      ;; Highlight message (and display XFace if supported)
	      (if (or vm-highlighted-header-regexp
		      (and (vm-xemacs-p) vm-use-lucid-highlighting))
		  (vm-highlight-headers))
 	      (if (and vm-use-menus (vm-menu-support-possible-p))
 		  (vm-energize-headers))	      ;;
	      (goto-char (point-min))
              (narrow-to-region (point) (search-forward "\n\n" nil t))
              ))
        ;; don't do MIME processing. decode header only.
        (let (buffer-read-only)
          (mime/decode-message-header))
        )
    ;; don't preview; do nothing.
    )
  (tm-vm/display-preview-buffer)
  (run-hooks 'tm-vm/select-message-hook))

(defun tm-vm/show-current-message ()
  (if mime::preview/article-buffer
      (set-buffer mime::preview/article-buffer)
    (vm-select-folder-buffer))
  ;; Now current buffer is folder buffer.
  (if (or t ; mime/viewer-mode doesn't support narrowing yet.
          (null vm-preview-lines)
          (and (not vm-preview-read-messages)
               (not (vm-new-flag
                     (car vm-message-pointer)))
               (not (vm-unread-flag
                     (car vm-message-pointer)))))
      (save-excursion
        (set-buffer mime::article/preview-buffer)
        (save-excursion
          (save-excursion
            (goto-char (point-min))
            (widen))
          ;; narrow to page; mime/viewer-mode doesn't support narrowing yet.
          )))
  (if (vm-get-visible-buffer-window mime::article/preview-buffer)
      (progn
        (setq tm-vm/system-state 'reading)
        (if (vm-new-flag (car vm-message-pointer))
            (vm-set-new-flag (car vm-message-pointer) nil))
        (if (vm-unread-flag (car vm-message-pointer))
            (vm-set-unread-flag (car vm-message-pointer) nil))
        (vm-update-summary-and-mode-line)
        (tm-vm/howl-if-eom))
    (vm-update-summary-and-mode-line)))

(defun tm-vm/toggle-preview-mode ()
  (interactive)
  (vm-select-folder-buffer)
  (vm-display (current-buffer) t (list this-command)
              (list this-command 'reading-message))
  (if tm-vm/automatic-mime-preview
      (setq tm-vm/automatic-mime-preview nil
            tm-vm/system-state nil)
    (setq tm-vm/automatic-mime-preview t
          tm-vm/system-state nil)
    (save-restriction
       (vm-widen-page)
       (let* ((mp (car vm-message-pointer))
              (exposed (= (point-min) (vm-start-of mp))))
         (if (or (not tm-vm/strict-mime)
                 (vm-get-header-contents mp "MIME-Version:"))
             ;; do MIME processiong.
             (progn
               (set (make-local-variable 'tm-vm/system-state) 'previewing)
               (save-window-excursion
                 (mime/viewer-mode)
                 (goto-char (point-min))
                 (narrow-to-region (point)
                                   (search-forward "\n\n" nil t))
                 ))
           ;; don't do MIME processing. decode header only.
           (let (buffer-read-only)
             (mime/decode-message-header))
           )
         ;; don't preview; do nothing.
         ))
    (tm-vm/display-preview-buffer)
    ))

(add-hook 'vm-select-message-hook 'tm-vm/preview-current-message)
(add-hook 'vm-visit-folder-hook   'tm-vm/preview-current-message)

;;; tm-vm move commands
;;;

(defmacro tm-vm/save-window-excursion (&rest forms)
  (list 'let '((tm-vm/selected-window (selected-window)))
        (list 'unwind-protect
              (cons 'progn forms)
              '(if (window-live-p tm-vm/selected-window)
                   (select-window tm-vm/selected-window)))))

;;; based on vm-scroll-forward [vm-page.el]
(defun tm-vm/scroll-forward (&optional arg)
  (interactive "P")
  (let ((this-command 'vm-scroll-forward))
    (if (not (tm-vm/system-state))
        (vm-scroll-forward arg)
      (let* ((mp-changed (vm-follow-summary-cursor))
             (mbuf (or (vm-select-folder-buffer) (current-buffer)))
             (mwin (vm-get-buffer-window mbuf))
             (pbuf (and mime::article/preview-buffer
                        (get-buffer mime::article/preview-buffer)))
             (pwin (and pbuf (vm-get-buffer-window pbuf)))
             (was-invisible (and (null mwin) (null pwin)))
             )
        ;; now current buffer is folder buffer.
        (tm-vm/save-window-excursion
         (if (or mp-changed was-invisible)
             (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
                         (list this-command 'reading-message)))
         (tm-vm/display-preview-buffer)
         (setq mwin (vm-get-buffer-window mbuf)
               pwin (and pbuf (vm-get-buffer-window pbuf)))
         (cond
          ((or mp-changed was-invisible)
           nil
           )
          ((null pbuf)
           ;; preview buffer is killed.
           (tm-vm/preview-current-message)
           (vm-update-summary-and-mode-line))
          ((eq (tm-vm/system-state) 'previewing)
           (tm-vm/show-current-message))
          (t
           (select-window pwin)
           (set-buffer pbuf)
           (if (pos-visible-in-window-p (point-max) pwin)
               (tm-vm/next-message)
             ;; not end of message. scroll preview buffer only.
             (scroll-up)
             (tm-vm/howl-if-eom)
             (set-buffer mbuf))
           ))))
      )))

;;; based on vm-scroll-backward [vm-page.el]
(defun tm-vm/scroll-backward (&optional arg)
  (interactive "P")
  (let ((this-command 'vm-scroll-backward))
    (if (not (tm-vm/system-state))
        (vm-scroll-backward arg)
      (let* ((mp-changed (vm-follow-summary-cursor))
             (mbuf (or (vm-select-folder-buffer) (current-buffer)))
             (mwin (vm-get-buffer-window mbuf))
             (pbuf (and mime::article/preview-buffer
                        (get-buffer mime::article/preview-buffer)))
             (pwin (and pbuf (vm-get-buffer-window pbuf)))
             (was-invisible (and (null mwin) (null pwin)))
             )
        ;; now current buffer is folder buffer.
        (if (or mp-changed was-invisible)
            (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
                        (list this-command 'reading-message)))
        (tm-vm/save-window-excursion
         (tm-vm/display-preview-buffer)
         (setq mwin (vm-get-buffer-window mbuf)
               pwin (and pbuf (vm-get-buffer-window pbuf)))
         (cond
          (was-invisible
           nil
           )
          ((null pbuf)
           ;; preview buffer is killed.
           (tm-vm/preview-current-message)
           (vm-update-summary-and-mode-line))
          ((eq (tm-vm/system-state) 'previewing)
           (tm-vm/show-current-message))
          (t
           (select-window pwin)
           (set-buffer pbuf)
           (if (pos-visible-in-window-p (point-min) pwin)
               nil
             ;; scroll preview buffer only.
             (scroll-down)
             (set-buffer mbuf))
           ))))
      )))

;;; based on vm-beginning-of-message [vm-page.el]
(defun tm-vm/beginning-of-message ()
  "Moves to the beginning of the current message."
  (interactive)
  (if (not (tm-vm/system-state))
      (progn
	(setq this-command 'vm-beginning-of-message)
	(vm-beginning-of-message))
    (vm-follow-summary-cursor)
    (vm-select-folder-buffer)
    (vm-check-for-killed-summary)
    (vm-error-if-folder-empty)
    (let ((mbuf (current-buffer))
          (pbuf (and mime::article/preview-buffer
                     (get-buffer mime::article/preview-buffer))))
      (if (null pbuf)
          (progn
            (tm-vm/preview-current-message)
            (setq pbuf (get-buffer mime::article/preview-buffer))
            ))
      (vm-display mbuf t '(vm-beginning-of-message)
                  '(vm-beginning-of-message reading-message))
      (tm-vm/display-preview-buffer)
      (set-buffer pbuf)
      (tm-vm/save-window-excursion
       (select-window (vm-get-buffer-window pbuf))
       (push-mark)
       (goto-char (point-min))
       ))))

;;; based on vm-end-of-message [vm-page.el]
(defun tm-vm/end-of-message ()
  "Moves to the end of the current message."
  (interactive)
  (if (not (tm-vm/system-state))
      (progn
	(setq this-command 'vm-end-of-message)
	(vm-end-of-message))
    (vm-follow-summary-cursor)
    (vm-select-folder-buffer)
    (vm-check-for-killed-summary)
    (vm-error-if-folder-empty)
    (let ((mbuf (current-buffer))
          (pbuf (and mime::article/preview-buffer
                     (get-buffer mime::article/preview-buffer))))
      (if (null pbuf)
          (progn
            (tm-vm/preview-current-message)
            (setq pbuf (get-buffer mime::article/preview-buffer))
            ))
      (vm-display mbuf t '(vm-end-of-message)
                  '(vm-end-of-message reading-message))
      (tm-vm/display-preview-buffer)
      (set-buffer pbuf)
      (tm-vm/save-window-excursion
       (select-window (vm-get-buffer-window pbuf))
       (push-mark)
       (goto-char (point-max))
       ))))

;;; based on vm-howl-if-eom [vm-page.el]
(defun tm-vm/howl-if-eom ()
  (let* ((pbuf (or mime::article/preview-buffer (current-buffer)))
         (pwin (and (vm-get-visible-buffer-window pbuf))))
    (and pwin
	 (save-excursion
	   (save-window-excursion
	     (condition-case ()
		 (let ((next-screen-context-lines 0))
		   (select-window pwin)
		   (save-excursion
		     (save-window-excursion
		       (let ((scroll-in-place-replace-original nil))
			 (scroll-up))))
		   nil)
	       (error t))))
         (tm-vm/emit-eom-blurb)
         )))

;;; based on vm-emit-eom-blurb [vm-page.el]
(defun tm-vm/emit-eom-blurb ()
  (save-excursion
    (if mime::preview/article-buffer
        (set-buffer mime::preview/article-buffer))
    (vm-emit-eom-blurb)))

;;; based on vm-quit [vm-folder.el]
(defun tm-vm/quit ()
  (interactive)
  (save-excursion
    (vm-select-folder-buffer)
    (if (and mime::article/preview-buffer
	     (get-buffer mime::article/preview-buffer))
	(kill-buffer mime::article/preview-buffer)))
  (vm-quit))

(substitute-key-definition 'vm-scroll-forward
			   'tm-vm/scroll-forward vm-mode-map)
(substitute-key-definition 'vm-scroll-backward
			   'tm-vm/scroll-backward vm-mode-map)
(substitute-key-definition 'vm-beginning-of-message
                           'tm-vm/beginning-of-message vm-mode-map)
(substitute-key-definition 'vm-end-of-message
                           'tm-vm/end-of-message vm-mode-map)
(substitute-key-definition 'vm-quit
			   'tm-vm/quit vm-mode-map)

;;; based on vm-next-message [vm-motion.el]                        
(defun tm-vm/next-message ()
  (set-buffer mime::preview/article-buffer)
  (let ((this-command 'vm-next-message)
        (owin (selected-window))
        (vm-preview-lines nil)
        )
    (vm-next-message 1 nil t)
    (if (window-live-p owin)
        (select-window owin))))

;;; based on vm-previous-message [vm-motion.el]
(defun tm-vm/previous-message ()
  (set-buffer mime::preview/article-buffer)
  (let ((this-command 'vm-previous-message)
        (owin (selected-window))
        (vm-preview-lines nil)
        )
    (vm-previous-message 1 nil t)
    (if (window-live-p owin)
        (select-window owin))))

(set-alist 'mime-viewer/over-to-previous-method-alist
	   'vm-mode 'tm-vm/previous-message)
(set-alist 'mime-viewer/over-to-next-method-alist
	   'vm-mode 'tm-vm/next-message)
(set-alist 'mime-viewer/over-to-previous-method-alist
	   'vm-virtual-mode 'tm-vm/previous-message)
(set-alist 'mime-viewer/over-to-next-method-alist
	   'vm-virtual-mode 'tm-vm/next-message)

;;; @@ vm-yank-message
;;;
;; 1996/3/28 by Oscar Figueiredo <figueire@lspsun16.epfl.ch>

(require 'vm-reply)

(defvar tm-vm/yank:message-to-restore nil
  "For internal use by tm-vm only.")

(defun vm-yank-message (&optional message)
  "Yank message number N into the current buffer at point.
When called interactively N is always read from the minibuffer.  When
called non-interactively the first argument is expected to be a
message struct.

This function originally provided by vm-reply has been patched for TM
in order to provide better citation of MIME messages : if a MIME
Preview buffer exists for the message then its contents are inserted
instead of the raw message.

This command is meant to be used in VM created Mail mode buffers; the
yanked message comes from the mail buffer containing the message you
are replying to, forwarding, or invoked VM's mail command from.

All message headers are yanked along with the text.  Point is
left before the inserted text, the mark after.  Any hook
functions bound to mail-citation-hook are run, after inserting
the text and setting point and mark.  For backward compatibility,
if mail-citation-hook is set to nil, `mail-yank-hooks' is run
instead.

If mail-citation-hook and mail-yank-hooks are both nil, this
default action is taken: the yanked headers are trimmed as
specified by vm-included-text-headers and
vm-included-text-discard-header-regexp, and the value of
vm-included-text-prefix is prepended to every yanked line."
  (interactive
   (list
    ;; What we really want for the first argument is a message struct,
    ;; but if called interactively, we let the user type in a message
    ;; number instead.
    (let (mp default
	     (result 0)
	     prompt
	     (last-command last-command)
	     (this-command this-command))
      (if (bufferp vm-mail-buffer)
          (save-excursion
            (vm-select-folder-buffer)
            (setq default (and vm-message-pointer
                               (vm-number-of (car vm-message-pointer)))
                  prompt (if default
                             (format "Yank message number: (default %s) "
                                     default)
                           "Yank message number: "))
            (while (zerop result)
              (setq result (read-string prompt))
              (and (string= result "") default (setq result default))
              (setq result (string-to-int result)))
            (if (null (setq mp (nthcdr (1- result) vm-message-list)))
                (error "No such message."))
	    (setq tm-vm/yank:message-to-restore (string-to-int default))
	    (save-selected-window
	      (vm-goto-message result))
            (car mp))
        nil))))
  (if (null message)
      (if mail-reply-buffer
          (tm-vm/yank-content)
        (error "This is not a VM Mail mode buffer."))
    (if (null (buffer-name vm-mail-buffer))
        (error "The folder buffer containing message %d has been killed."
               (vm-number-of message)))
    (vm-display nil nil '(vm-yank-message)
                '(vm-yank-message composing-message))
    (let ((b (current-buffer)) (start (point)) end)
      (save-restriction
        (widen)
        (save-excursion
          (set-buffer (vm-buffer-of message))
          (let* ((mbuf (current-buffer))
                 (pbuf (and mime::article/preview-buffer
					; is there a preview buffer alive ?
			    (get-buffer mime::article/preview-buffer)
					; rebuild preview to ensure it
					; corresponds to the current message
			    (save-excursion
			      (save-selected-window
				(save-window-excursion
				  (tm-vm/view-message))))
                            (get-buffer mime::article/preview-buffer))))
            (if pbuf
                (if running-xemacs
                    (let ((tmp (generate-new-buffer "tm-vm/tmp")))
                      (set-buffer pbuf)
                      (append-to-buffer tmp (point-min) (point-max))
                      (set-buffer tmp)
                      (map-extents
                       '(lambda (ext maparg) 
                          (set-extent-property ext 'begin-glyph nil)))
                      (append-to-buffer b (point-min) (point-max))
                      (setq end (vm-marker
                                 (+ start (length (buffer-string))) b))
                      (kill-buffer tmp))
                  (set-buffer pbuf)
                  (append-to-buffer b (point-min) (point-max))
                  (setq end (vm-marker
                             (+ start (length (buffer-string))) b)))
              (save-restriction
		(setq message (vm-real-message-of message))
		(set-buffer (vm-buffer-of message))
		(widen)
                (append-to-buffer
                 b (vm-headers-of message) (vm-text-end-of message))
                (setq end
                      (vm-marker (+ start (- (vm-text-end-of message)
                                             (vm-headers-of message))) b))))))
        (push-mark end)
        (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
              (mail-yank-hooks (run-hooks 'mail-yank-hooks))
              (t (vm-mail-yank-default message)))
        ))
    (if tm-vm/yank:message-to-restore
	(save-selected-window
	  (vm-goto-message tm-vm/yank:message-to-restore)
	  (setq tm-vm/yank:message-to-restore nil)))
    ))


;;; @ for tm-view
;;;

;;; based on vm-do-reply [vm-reply.el]
(defun tm-vm/do-reply (buf to-all include-text)
  (save-excursion
    (set-buffer buf)
    (let ((dir default-directory)
          to cc subject mp in-reply-to references newsgroups)
      (cond ((setq to
                   (let ((reply-to (std11-field-body "Reply-To")))
                     (if (vm-ignored-reply-to reply-to)
                         nil
                       reply-to))))
            ((setq to (std11-field-body "From")))
            ;; (t (error "No From: or Reply-To: header in message"))
            )
      (if to-all
          (setq cc (delq nil (cons cc (std11-field-bodies '("To" "Cc"))))
                cc (mapconcat 'identity cc ","))
        )
      (setq subject (std11-field-body "Subject"))
      (and subject vm-reply-subject-prefix
           (let ((case-fold-search t))
             (not
              (equal
               (string-match (regexp-quote vm-reply-subject-prefix)
                             subject)
               0)))
           (setq subject (concat vm-reply-subject-prefix subject)))
      (setq in-reply-to (std11-field-body "Message-Id")
            references (nconc
                        (std11-field-bodies '("References" "In-Reply-To"))
                        (list in-reply-to))
            newsgroups (list (or (and to-all
                                      (std11-field-body "Followup-To"))
                                 (std11-field-body "Newsgroups"))))
      (setq to (vm-parse-addresses to)
            cc (vm-parse-addresses cc))
      (if vm-reply-ignored-addresses
          (setq to (vm-strip-ignored-addresses to)
                cc (vm-strip-ignored-addresses cc)))
      (setq to (vm-delete-duplicates to nil t))
      (setq cc (vm-delete-duplicates
                (append (vm-delete-duplicates cc nil t)
                        to (copy-sequence to))
                t t))
      (and to (setq to (mapconcat 'identity to ",\n ")))
      (and cc (setq cc (mapconcat 'identity cc ",\n ")))
      (and (null to) (setq to cc cc nil))
      (setq references (delq nil references)
            references (mapconcat 'identity references " ")
            references (vm-parse references "[^<]*\\(<[^>]+>\\)")
            references (vm-delete-duplicates references)
            references (if references (mapconcat 'identity references "\n\t")))
      (setq newsgroups (delq nil newsgroups)
            newsgroups (mapconcat 'identity newsgroups ",")
            newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
            newsgroups (vm-delete-duplicates newsgroups)
            newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
      (vm-mail-internal
       (if to
           (format "reply to %s%s"
                   (std11-full-name-string
		    (car (std11-parse-address-string to)))
		   (if cc ", ..." "")))
       to subject in-reply-to cc references newsgroups)
      (setq mail-reply-buffer buf
            ;; vm-system-state 'replying
            default-directory dir))
    (if include-text
        (save-excursion
          (goto-char (point-min))
          (let ((case-fold-search nil))
            (re-search-forward
             (concat "^" (regexp-quote mail-header-separator) "$") nil 0))
          (forward-char 1)
          (tm-vm/yank-content)))
    (run-hooks 'vm-reply-hook)
    (run-hooks 'vm-mail-mode-hook)
    ))

(defun tm-vm/following-method (buf)
  (tm-vm/do-reply buf 'to-all 'include-text)
  )

(defun tm-vm/yank-content ()
  (interactive)
  (let ((this-command 'vm-yank-message))
    (vm-display nil nil '(vm-yank-message)
                '(vm-yank-message composing-message))
    (save-restriction
      (narrow-to-region (point)(point))
      (insert-buffer mail-reply-buffer)
      (goto-char (point-max))
      (push-mark)
      (goto-char (point-min)))
    (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
          (mail-yank-hooks (run-hooks 'mail-yank-hooks))
          (t (mail-indent-citation)))
    ))

(set-alist 'mime-viewer/following-method-alist
	   'vm-mode
	   (function tm-vm/following-method))
(set-alist 'mime-viewer/following-method-alist
	   'vm-virtual-mode
	   (function tm-vm/following-method))


(defun tm-vm/quit-view-message ()
  "Quit MIME-viewer and go back to VM.
This function is called by `mime-viewer/quit' command via
`mime-viewer/quitting-method-alist'."
  (if (get-buffer mime/output-buffer-name)
      (vm-undisplay-buffer mime/output-buffer-name))
  (if (and tm-vm/automatic-mime-preview
           (save-excursion
             (set-buffer mime::preview/article-buffer)
             vm-summary-buffer))
      (switch-to-buffer mime::preview/article-buffer)
    (mime-viewer/kill-buffer)
    (vm-select-folder-buffer)
    (setq tm-vm/system-state nil))
  (vm-display (current-buffer) t (list this-command)
              (list this-command 'reading-message))
  (tm-vm/display-preview-buffer)
  )

(defun tm-vm/view-message ()
  "Decode and view MIME encoded message, under VM."
  (interactive)
  (vm-follow-summary-cursor)
  (vm-select-folder-buffer)
  (vm-check-for-killed-summary)
  (vm-error-if-folder-empty)
  (vm-display (current-buffer) t '(tm-vm/view-message)
              '(tm-vm/view-mesage reading-message))
  (let* ((mp (car vm-message-pointer))
	 (ct  (vm-get-header-contents mp "Content-Type:"))
	 (cte (vm-get-header-contents mp "Content-Transfer-Encoding:"))
	 (exposed (= (point-min) (vm-start-of mp))))
    (save-restriction
      (vm-widen-page)
      ;; vm-widen-page hides exposed header if pages are delimited.
      ;; So, here we expose it again.
      (if exposed
	  (narrow-to-region (vm-start-of mp) (point-max)))
      (select-window (vm-get-buffer-window (current-buffer)))
      (mime/viewer-mode nil
			(mime/parse-Content-Type (or ct ""))
			cte)
      )))

(set-alist 'mime-viewer/quitting-method-alist
	   'vm-mode
	   'tm-vm/quit-view-message)

(set-alist 'mime-viewer/quitting-method-alist
	   'vm-virtual-mode
	   'tm-vm/quit-view-message)


;;; @ for tm-partial
;;;

(call-after-loaded
 'tm-partial
 (function
  (lambda ()
    (set-atype 'mime/content-decoding-condition
	       '((type . "message/partial")
		 (method . mime-article/grab-message/partials)
		 (major-mode . vm-mode)
		 (summary-buffer-exp . vm-summary-buffer)
		 ))
    (set-alist 'tm-partial/preview-article-method-alist
	       'vm-mode
	       (function
		(lambda ()
		  (tm-vm/view-message)
		  )))
    )))


;;; @ for tm-edit
;;;

;;; @@ for multipart/digest
;;;

(defvar tm-vm/forward-message-hook nil
  "*List of functions called after a Mail mode buffer has been
created to forward a message in message/rfc822 type format.
If `vm-forwarding-digest-type' is \"rfc1521\", tm-vm runs this
hook instead of `vm-forward-message-hook'.")

(defvar tm-vm/send-digest-hook nil
  "*List of functions called after a Mail mode buffer has been
created to send a digest in multipart/digest type format.
If `vm-digest-send-type' is \"rfc1521\", tm-vm runs this hook
instead of `vm-send-digest-hook'.")

(defun tm-vm/enclose-messages (mlist &optional preamble)
  "Enclose the messages in MLIST as multipart/digest.
The resulting digest is inserted at point in the current buffer.

MLIST should be a list of message structs (real or virtual).
These are the messages that will be enclosed."
  (if mlist
      (let ((digest (consp (cdr mlist)))
            (mp mlist)
            m)
	(save-restriction
	  (narrow-to-region (point) (point))
	  (while mlist
	    (setq m (vm-real-message-of (car mlist)))
            (mime-editor/insert-tag "message" "rfc822")
            (tm-mail/insert-message m)
            (goto-char (point-max))
	    (setq mlist (cdr mlist)))
          (if preamble
              (progn
                (goto-char (point-min))
                (mime-editor/insert-tag "text" "plain")
                (vm-unsaved-message "Building digest preamble...")
                (while mp
                  (let ((vm-summary-uninteresting-senders nil))
                    (insert
                     (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n"))
                  (if vm-digest-center-preamble
                      (progn
                        (forward-char -1)
                        (center-line)
                        (forward-char 1)))
                  (setq mp (cdr mp)))))
          (if digest
              (mime-editor/enclose-digest-region (point-min) (point-max)))
          ))))

(defun tm-vm/forward-message ()
  "Forward the current message to one or more recipients.
You will be placed in a Mail mode buffer as you would with a
reply, but you must fill in the To: header and perhaps the
Subject: header manually."
  (interactive)
  (if (not (equal vm-forwarding-digest-type "rfc1521"))
      (vm-forward-message)
    (vm-follow-summary-cursor)
    (vm-select-folder-buffer)
    (vm-check-for-killed-summary)
    (vm-error-if-folder-empty)
    (if (eq last-command 'vm-next-command-uses-marks)
        (let ((vm-digest-send-type vm-forwarding-digest-type))
          (setq this-command 'vm-next-command-uses-marks)
          (command-execute 'tm-vm/send-digest))
      (let ((dir default-directory)
            (mp vm-message-pointer))
        (save-restriction
          (widen)
          (vm-mail-internal
           (format "forward of %s's note re: %s"
                   (vm-su-full-name (car vm-message-pointer))
                   (vm-su-subject (car vm-message-pointer)))
           nil
           (and vm-forwarding-subject-format
                (let ((vm-summary-uninteresting-senders nil))
                  (vm-sprintf 'vm-forwarding-subject-format (car mp)))))
          (make-local-variable 'vm-forward-list)
          (setq vm-system-state 'forwarding
                vm-forward-list (list (car mp))
                default-directory dir)
          (goto-char (point-min))
          (re-search-forward
           (concat "^" (regexp-quote mail-header-separator) "\n") nil 0)
          (tm-vm/enclose-messages vm-forward-list)
          (mail-position-on-field "To"))
        (run-hooks 'tm-vm/forward-message-hook)
        (run-hooks 'vm-mail-mode-hook)))))

(defun tm-vm/send-digest (&optional arg)
  "Send a digest of all messages in the current folder to recipients.
The type of the digest is specified by the variable vm-digest-send-type.
You will be placed in a Mail mode buffer as is usual with replies, but you
must fill in the To: and Subject: headers manually.

If invoked on marked messages (via vm-next-command-uses-marks),
only marked messages will be put into the digest."
  (interactive "P")
  (if (not (equal vm-digest-send-type "rfc1521"))
      (vm-send-digest arg)
    (vm-select-folder-buffer)
    (vm-check-for-killed-summary)
    (vm-error-if-folder-empty)
    (let ((dir default-directory)
          (vm-forward-list (if (eq last-command 'vm-next-command-uses-marks)
                               (vm-select-marked-or-prefixed-messages 0)
                             vm-message-list))
          start)
      (save-restriction
        (widen)
        (vm-mail-internal (format "digest from %s" (buffer-name)))
        (setq vm-system-state 'forwarding
              default-directory dir)
        (goto-char (point-min))
        (re-search-forward (concat "^" (regexp-quote mail-header-separator)
                                   "\n"))
        (goto-char (match-end 0))
        (vm-unsaved-message "Building %s digest..." vm-digest-send-type)
        (tm-vm/enclose-messages vm-forward-list arg)
        (mail-position-on-field "To")
        (message "Building %s digest... done" vm-digest-send-type)))
    (run-hooks 'tm-vm/send-digest-hook)
    (run-hooks 'vm-mail-mode-hook)))

(substitute-key-definition 'vm-forward-message
			   'tm-vm/forward-message vm-mode-map)
(substitute-key-definition 'vm-send-digest
			   'tm-vm/send-digest vm-mode-map)


;;; @@ setting
;;;

(defvar tm-vm/use-xemacs-popup-menu t)

;;; modified by Steven L. Baur <steve@miranova.com>
;;;	1995/12/6 (c.f. [tm-en:209])
(defun mime-editor/attach-to-vm-mode-menu ()
  "Arrange to attach MIME editor's popup menu to VM's"
  (if (boundp 'vm-menu-mail-menu)
      (progn
	(setq vm-menu-mail-menu
	      (append vm-menu-mail-menu
		      (list "----"
			    mime-editor/popup-menu-for-xemacs)))
	(remove-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu)
	)))

(call-after-loaded
 'tm-edit
 (function
  (lambda ()
    (autoload 'tm-mail/insert-message "tm-mail")
    (set-alist 'mime-editor/message-inserter-alist
	       'mail-mode (function tm-mail/insert-message))
    (set-alist 'mime-editor/split-message-sender-alist
               'mail-mode (function
                           (lambda ()
                             (interactive)
                             (sendmail-send-it)
                             )))
    (if (and (string-match "XEmacs\\|Lucid" emacs-version)
	     tm-vm/use-xemacs-popup-menu)
	(add-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu)
      )
    )))

(call-after-loaded
 'mime-setup
 (function
  (lambda ()
    (setq vm-forwarding-digest-type "rfc1521")
    (setq vm-digest-send-type "rfc1521")
    )))


;;; @ for BBDB
;;;

(call-after-loaded
 'bbdb
 (function
  (lambda ()
    (require 'bbdb-vm)
    (require 'tm-bbdb)
    (or (fboundp 'tm:bbdb/vm-update-record)
        (fset 'tm:bbdb/vm-update-record
              (symbol-function 'bbdb/vm-update-record)))
    (defun bbdb/vm-update-record (&optional offer-to-create)
      (vm-select-folder-buffer)
      (if (and (tm-vm/system-state)
               mime::article/preview-buffer
               (get-buffer mime::article/preview-buffer))
          (tm-bbdb/update-record offer-to-create)
        (tm:bbdb/vm-update-record offer-to-create)
        ))
    (remove-hook 'vm-select-message-hook 'bbdb/vm-update-record)
    (remove-hook 'vm-show-message-hook 'bbdb/vm-update-record)
    (add-hook 'tm-vm/select-message-hook 'bbdb/vm-update-record)
    )))


;;; @ end
;;;

(provide 'tm-vm)

(run-hooks 'tm-vm-load-hook)

;;; tm-vm.el ends here.