;;;
;;; 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@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
+;;; Copyright (C) 1994 MASUTANI Yasuhiro
+;;; Copyright (C) 1995 WAKAMIYA Kenji
+;;; Copyright (C) 1995,1996 KOBAYASHI Shuhei
+;;; Copyright (C) 1996 Oscar Figueiredo
+;;;
+;;; Author: MASUTANI Yasuhiro <masutani@me.es.osaka-u.ac.jp>
+;;; Kenji Wakamiya <wkenji@flab.fujitsu.co.jp>
+;;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;;; KOBAYASHI Shuhei <shuhei-k@jaist.ac.jp>
+;;; Oscar Figueiredo <figueire@lspsun2.epfl.ch>
+;;; modified by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
+;;; ISHIHARA Akito <aki@bpel.tutics.tut.ac.jp>
+;;; Rob Kooper <kooper@cc.gatech.edu>
+;;; Maintainer: KOBAYASHI Shuhei <shuhei-k@jaist.ac.jp>
+;;; Created: 1994/10/29
+;;; Version: $Revision: 7.53 $
+;;; Keywords: mail, MIME, multimedia, multilingual, encoded-word
;;;
;;; This file is part of tm (Tools for MIME).
;;;
-;;; This version is tested under VM-5.76 with tm-6.20.
+;;; 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.
;;;
-;;; Plese insert (require 'tm-vm) in your .vm or .emacs.
+;;; 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.
;;;
+;;; 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.3 1995/10/28 06:00:09 morioka Exp $")
+ "$Id: tm-vm.el,v 7.53 1996/05/23 16:51:04 shuhei-k 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)
-(set-alist 'mime-viewer/quitting-method-alist
- 'vm-mode
- 'tm-vm/quit-view-message)
+(defvar tm-vm/use-original-url-button nil
+ "*If it is t, use original URL button instead of tm's.")
-(set-alist 'mime-viewer/quitting-method-alist
- 'vm-virtual-mode
- 'tm-vm/quit-view-message)
+(defvar tm-vm-load-hook nil
+ "*List of functions called after tm-vm is loaded.")
;;; @ for MIME encoded-words
;;;
-;; If you don't use tiny-mime patch for VM (by RIKITAKE Kenji
-;; <kenji@reseau.toyonaka.osaka.jp>), please use following definition:
-;; (setq vm-summary-format "%n %*%a %-17.17F %-3.3m %2d %4l/%-5c, %I\"%UA\"\n")
-;; (defun vm-summary-function-A (m)
-;; (mime-ewords/decode-string (vm-su-subject m)))
+(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]")
-
-;;; @ functions
+(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/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/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)))
-(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)
- )))
+(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.
+ "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.
(vm-preview-current-message)
(setq vbufs (cdr vbufs))))))
+\f
+;;; @ 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))
+ ;;
+ (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)
+\f
+;;; 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)
+
+(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 is displayed 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."))
+ (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))
+ (setq message (vm-real-message-of 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
+ (get-buffer mime::article/preview-buffer)))
+ (pwin (and pbuf (vm-get-visible-buffer-window pbuf))))
+ (if pwin
+ (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
+ (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)))
+ ))
+ ))
+
+\f
+;;; @ 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 (rfc822/get-field-body "Reply-To")))
+ (if (vm-ignored-reply-to reply-to)
+ nil
+ reply-to))))
+ ((setq to (rfc822/get-field-body "From")))
+ ;; (t (error "No From: or Reply-To: header in message"))
+ )
+ (if to-all
+ (setq cc (delq nil (cons cc (rfc822/get-field-bodies '("To" "Cc"))))
+ cc (mapconcat 'identity cc ","))
+ )
+ (setq subject (rfc822/get-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 (rfc822/get-field-body "Message-Id")
+ references (nconc
+ (rfc822/get-field-bodies '("References" "In-Reply-To"))
+ (list in-reply-to))
+ newsgroups (list (or (and to-all
+ (rfc822/get-field-body "Followup-To"))
+ (rfc822/get-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"
+ (rfc822/full-name-string
+ (car (rfc822/parse-address
+ (rfc822/lexical-analyze 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
;;;
;;; @ 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)
+\f
+
+;;; @@ 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 ()
- (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")
+ )))
+
+
+;;; @ 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)
)))
;;;
(provide 'tm-vm)
+
+(run-hooks 'tm-vm-load-hook)
+
+;;; tm-vm.el ends here.
projects / elisp / tm.git / blobdiff