;;;
;;; tm-vm.el --- tm-MUA for VM
;;;
;;; Copyright (C) 1995 Free Software Foundation, Inc.
;;; 
;;; Author:   MASUTANI Yasuhiro <masutani@me.es.osaka-u.ac.jp>
;;;          and Kenji Wakamiya <wkenji@flab.fujitsu.co.jp>
;;; modified by SHIONO Jun'ichi <jun@p5.nm.fujitsu.co.jp>,
;;;                Steinar Bang <steinarb@falch.no>,
;;;            Shuhei KOBAYASHI <shuhei@cmpt01.phys.tohoku.ac.jp>,
;;;        and MORIOKA Tomohiko <morioka@jaist.ac.jp>
;;; Keywords: news, MIME, multimedia, multilingual, encoded-word
;;;
;;; This file is part of tm (Tools for MIME).
;;;
;;; Plese insert (require 'tm-vm) in your .vm or .emacs.
;;;

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

(defconst tm-vm/RCS-ID
  "$Id: tm-vm.el,v 7.4 1995/11/14 04:52:30 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)


;;; @ 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
;;;
;; by Steinar Bang <steinarb@falch.no>
(setq vm-summary-format "%n %*%a %-17.17F %-3.3m %2d %4l/%-5c, %I\"%UA\"\n")

(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)))

;; by Steinar Bang <steinarb@falch.no>
(defun vm-summary-function-A (m)
  (mime-eword/decode-string (vm-su-subject 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.")

(defun tm-vm/preview-current-message ()
  (if tm-vm/automatic-mime-preview
      (let ((win (selected-window)))
	(vm-display (current-buffer) t
		    '(tm-vm/preview-current-message
		      vm-preview-current-message)
		    '(tm-vm/preview-current-message reading-message))
	(mime/viewer-mode)
	(select-window win)
	)
    ))

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

(defun tm-vm/scroll-forward ()
  (interactive)
  (if tm-vm/automatic-mime-preview
      (let ((win (get-buffer-window
		  (save-excursion
		    (set-buffer vm-mail-buffer)
		    mime::article/preview-buffer)))
	    (the-win (selected-window))
	    np)
	(if win
	    (progn
	      (select-window win)
	      (setq np (save-excursion
			 (forward-line (window-height))
			 (point)
			 ))
	      )
	  (vm-scroll-forward)
	  (switch-to-buffer mime::article/preview-buffer)
	  (setq win (selected-window))
	  (setq np (point-min))
	  )
	(if (eq np (point-max))
	    (progn
	      (select-window the-win)
	      (vm-next-message)
	      )
	  (set-window-start (selected-window) np)
	  (select-window the-win)
	  ))
    (vm-scroll-forward)
    ))

(defun tm-vm/scroll-backward ()
  (interactive)
  (if tm-vm/automatic-mime-preview
      (let ((win (get-buffer-window
		  (save-excursion
		    (set-buffer vm-mail-buffer)
		    mime::article/preview-buffer)))
	    (the-win (selected-window))
	    np)
	(if win
	    (progn
	      (select-window win)
	      (setq np (save-excursion
			 (forward-line (- (window-height)))
			 (point)
			 ))
	      (if (eq np (window-start))
		  (progn
		    (select-window the-win)
		    (vm-previous-message)
		    )
		(set-window-start (selected-window) np)
		(select-window the-win)
		))
	  (vm-scroll-forward)
	  (switch-to-buffer mime::article/preview-buffer)
	  (setq win (selected-window))
	  (select-window the-win)
	  ))
    (vm-scroll-backward)
    ))

(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)

(defun tm-vm/toggle-preview-mode ()
  (interactive)
  (if tm-vm/automatic-mime-preview
      (progn
	(setq tm-vm/automatic-mime-preview nil)
	(vm-select-folder-buffer)
	(vm-display (current-buffer) t
		    '(tm-vm/toggle-preview-mode)
		    '(tm-vm/toggle-preview-mode reading-message))
	)
    (setq tm-vm/automatic-mime-preview t)
    (let ((win (selected-window)))
      (vm-select-folder-buffer)
      (save-window-excursion
	(let* ((mp (car vm-message-pointer))
	       (ct  (vm-get-header-contents mp "Content-Type:"))
	       (cte (vm-get-header-contents mp "Content-Transfer-Encoding:"))
	       )
	  (mime/viewer-mode nil (mime/parse-Content-Type (or ct "")) cte)
	  ))
      (vm-display mime::article/preview-buffer t
		  '(tm-vm/toggle-preview-mode)
		  '(tm-vm/toggle-preview-mode reading-message))
      (select-window win)
      )
    ))

	
;;; @ 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'."
  (mime-viewer/kill-buffer)
  (if (get-buffer mime/output-buffer-name)
      (bury-buffer mime/output-buffer-name))
  (vm-select-folder-buffer)
  (vm-display (current-buffer) t '(mime-viewer/quit mime-viewer/up-content)
	      '(mime-viewer/quit reading-message)))

(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
;;;

;; 1995/11/9 by Shuhei KOBAYASHI <shuhei@cmpt01.phys.tohoku.ac.jp>
;;	(c.f. [tm ML:1075])
(defun tm-vm/insert-message (&optional message)
  (interactive)
  (let* (mail-yank-hooks
	 (mail-citation-hook '(mime-editor/inserted-message-filter))
	 (mail-reply-buffer vm-mail-buffer)
	 )
    (if (null message)
        (call-interactively 'vm-yank-message)
      (vm-yank-message message))
    ))


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

(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 (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-vm/insert-message m)
            (goto-char (point-max))
	    (setq mlist (cdr mlist)))
          (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) ; Is it necessary?
        (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)
          (mlist (if (eq last-command 'vm-next-command-uses-marks)
                     (vm-select-marked-or-prefixed-messages 0)
                   vm-message-list)))
      (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 mlist)
        (mail-position-on-field "To")
        (message "Building %s digest... done" vm-digest-send-type)))
    ;; (run-hooks 'tm-vm/send-digest-hook) ; Is it necessary?
    (run-hooks 'vm-mail-mode-hook)))


;;; @@ setting
;;;

(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)

(call-after-loaded
 'tm-edit
 (function
  (lambda ()
    (set-alist 'mime-editor/message-inserter-alist
	       'mail-mode (function tm-vm/insert-message))
    )))

(call-after-loaded
 'mime-setup
 (function
  (lambda ()
    (remove-hook 'mail-mode-hook 'mime/editor-mode)
    (add-hook 'vm-mail-mode-hook 'mime/editor-mode)
    (setq vm-forwarding-digest-type "rfc1521")
    (setq vm-digest-send-type "rfc1521")
    )))


;;; @ end
;;;

(provide 'tm-vm)