X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=tm-vm.el;h=962cc18f5652ea575e6ed1d467254f52cc06670f;hb=29e661110079bf0d047d34fa64f7a963d06b7522;hp=9649c1d2d34a0d1b4f3a1f34cd8cf12c6f9a6975;hpb=76429e73b11fa30d585ffd90dc5f6cfbb427219d;p=elisp%2Ftm.git diff --git a/tm-vm.el b/tm-vm.el index 9649c1d..962cc18 100644 --- a/tm-vm.el +++ b/tm-vm.el @@ -1,85 +1,107 @@ -;;; -;;; tm-vm.el: tm-MUA for VM -;;; This version is tested under VM-5.76 with tm-6.20 -;;; -;;; Written by MASUTANI Yasuhiro -;;; Modified by SHIONO -;;; and Steinar Bang -;;; and Kenji Wakamiya -;;; -;;; Plese insert (require 'tm-vm) in your .vm or .emacs. -;;; +;;; tm-vm.el --- tm-MUA (MIME Extension module) for VM + +;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. + +;; Author: MASUTANI Yasuhiro +;; Kenji Wakamiya +;; MORIOKA Tomohiko +;; Shuhei KOBAYASHI +;; Oscar Figueiredo +;; Maintainer: Shuhei KOBAYASHI +;; 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: -(provide 'tm-vm) (require 'tm-view) (require 'vm) (defconst tm-vm/RCS-ID - "$Id: tm-vm.el,v 6.1 1995/05/16 12:33:21 morioka Exp $") + "$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) -(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 header -;;; -;; If you don't use tiny-mime patch for VM (by RIKITAKE Kenji -;; ), 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/decode-string (vm-su-subject m))) +;;; @ 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 +), 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-field-body/Content-Type - (message/unfolding-string (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. @@ -128,3 +150,941 @@ all marked messages are affected, other messages are ignored." (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 + ;; 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 + +(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 +;;; 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.