;;;
;;; tm-vm.el --- tm-MUA for VM
;;;
;;; Copyright (C) 1994 MASUTANI Yasuhiro
;;; Copyright (C) 1995 WAKAMIYA Kenji
;;; Copyright (C) 1995,1996 KOBAYASHI Shuhei
;;; 
;;; 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@cmpt01.phys.tohoku.ac.jp>
;;;         Oscar Figueiredo <figueire@lspsun2.epfl.ch>
;;; modified by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
;;;         and ISHIHARA Akito <aki@bpel.tutics.tut.ac.jp>
;;; Maintainer: Shuhei KOBAYASHI <shuhei@cmpt01.phys.tohoku.ac.jp>
;;; Created: 1994/10/29
;;; Version: $Revision: 7.44 $
;;; Keywords: mail, MIME, multimedia, multilingual, encoded-word
;;;
;;; This file is part of tm (Tools for MIME).
;;;
;;; Plese insert `(require 'tm-vm)' in your ~/.vm file.
;;;
;;; 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.  If not, write to the Free Software
;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;
;;; Code:

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

(defconst tm-vm/RCS-ID
  "$Id: tm-vm.el,v 7.44 1996/02/23 22:00:46 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-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 through tiny-mime.
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)
              (goto-char (point-min))
	      ;; 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))
	      ;;
              (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
          (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)


;;; @ for tm-view
;;;

(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)
  "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)))
            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 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 prefix)
  "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 prefix)
    (vm-select-folder-buffer)
    (vm-check-for-killed-summary)
    (vm-error-if-folder-empty)
    (let ((dir default-directory)
          (mp vm-message-pointer)
          (mlist (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
              vm-forward-list mlist
              default-directory dir)
        (goto-char (point-min))
        (re-search-forward (concat "^" (regexp-quote mail-header-separator)
                                   "\n"))
        (goto-char (match-end 0))
        (setq start (point)
              mp mlist)
        (vm-unsaved-message "Building %s digest..." vm-digest-send-type)
        (tm-vm/enclose-messages mlist)
        (goto-char start)
        (setq mp mlist)
        (if prefix
	  (progn
            (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)))))
        (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)

;;; @@ for message/rfc822
;;;


;;; @@ 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))
    (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.