+++ /dev/null
-;;; tm-vm.el --- tm-MUA (MIME Extension module) for VM
-
-;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc.
-
-;; Author: MASUTANI Yasuhiro <masutani@me.es.osaka-u.ac.jp>
-;; Kenji Wakamiya <wkenji@flab.fujitsu.co.jp>
-;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
-;; Oscar Figueiredo <figueire@lspsun2.epfl.ch>
-;; Maintainer: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
-;; Created: 1994/10/29
-;; Version: $Revision: 7.62 $
-;; Keywords: mail, MIME, multimedia, multilingual, encoded-word
-
-;; This file is part of tm (Tools for MIME).
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or (at
-;; your option) any later version.
-
-;; This program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; Plese insert `(require 'tm-vm)' in your ~/.vm file.
-
-;;; Code:
-
-(require 'tm-view)
-(require 'vm)
-
-(defconst tm-vm/RCS-ID
- "$Id: tm-vm.el,v 7.62 1996/08/31 14:24:35 morioka Exp $")
-(defconst tm-vm/version (get-version-string tm-vm/RCS-ID))
-
-(define-key vm-mode-map "Z" 'tm-vm/view-message)
-(define-key vm-mode-map "T" 'tm-vm/decode-message-header)
-(define-key vm-mode-map "\et" 'tm-vm/toggle-preview-mode)
-
-(defvar tm-vm/use-original-url-button nil
- "*If it is t, use original URL button instead of tm's.")
-
-(defvar tm-vm-load-hook nil
- "*List of functions called after tm-vm is loaded.")
-
-
-;;; @ for MIME encoded-words
-;;;
-
-(defvar tm-vm/use-tm-patch nil
- "Does not decode encoded-words in summary buffer if it is t.
-If you use tiny-mime patch for VM (by RIKITAKE Kenji
-<kenji@reseau.toyonaka.osaka.jp>), please set it t [tm-vm.el]")
-
-(or tm-vm/use-tm-patch
- (progn
-;;;
-(defvar tm-vm/chop-full-name-function 'tm-vm/default-chop-full-name)
-(setq vm-chop-full-name-function tm-vm/chop-full-name-function)
-
-(defun tm-vm/default-chop-full-name (address)
- (let* ((ret (vm-default-chop-full-name address))
- (full-name (car ret))
- )
- (if (stringp full-name)
- (cons (mime-eword/decode-string full-name)
- (cdr ret))
- ret)))
-
-(require 'vm-summary)
-(or (fboundp 'tm:vm-su-subject)
- (fset 'tm:vm-su-subject (symbol-function 'vm-su-subject))
- )
-(defun vm-su-subject (m)
- (mime-eword/decode-string (tm:vm-su-subject m))
- )
-
-(or (fboundp 'tm:vm-su-full-name)
- (fset 'tm:vm-su-full-name (symbol-function 'vm-su-full-name))
- )
-(defun vm-su-full-name (m)
- (mime-eword/decode-string (tm:vm-su-full-name m))
- )
-
-(or (fboundp 'tm:vm-su-to-names)
- (fset 'tm:vm-su-to-names (symbol-function 'vm-su-to-names))
- )
-(defun vm-su-to-names (m)
- (mime-eword/decode-string (tm:vm-su-to-names m))
- )
-;;;
-))
-
-(defun tm-vm/decode-message-header (&optional count)
- "Decode MIME header of current message.
-Numeric prefix argument COUNT means to decode the current message plus
-the next COUNT-1 messages. A negative COUNT means decode the current
-message and the previous COUNT-1 messages.
-When invoked on marked messages (via vm-next-command-uses-marks),
-all marked messages are affected, other messages are ignored."
- (interactive "p")
- (or count (setq count 1))
- (vm-follow-summary-cursor)
- (vm-select-folder-buffer)
- (vm-check-for-killed-summary)
- (vm-error-if-folder-empty)
- (vm-error-if-folder-read-only)
- (let ((mlist (vm-select-marked-or-prefixed-messages count))
- (realm nil)
- (vlist nil)
- (vbufs nil))
- (save-excursion
- (while mlist
- (setq realm (vm-real-message-of (car mlist)))
- ;; Go to real folder of this message.
- ;; But maybe this message is already real message...
- (set-buffer (vm-buffer-of realm))
- (let ((buffer-read-only nil))
- (vm-save-restriction
- (narrow-to-region (vm-headers-of realm) (vm-text-of realm))
- (mime/decode-message-header))
- (let ((vm-message-pointer (list realm))
- (last-command nil))
- (vm-discard-cached-data))
- ;; Mark each virtual and real message for later summary
- ;; update.
- (setq vlist (cons realm (vm-virtual-messages-of realm)))
- (while vlist
- (vm-mark-for-summary-update (car vlist))
- ;; Remember virtual and real folders related this message,
- ;; for later display update.
- (or (memq (vm-buffer-of (car vlist)) vbufs)
- (setq vbufs (cons (vm-buffer-of (car vlist)) vbufs)))
- (setq vlist (cdr vlist)))
- (if (eq vm-flush-interval t)
- (vm-stuff-virtual-attributes realm)
- (vm-set-modflag-of realm t)))
- (setq mlist (cdr mlist)))
- ;; Update mail-buffers and summaries.
- (while vbufs
- (set-buffer (car vbufs))
- (vm-preview-current-message)
- (setq vbufs (cdr vbufs))))))
-
-\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))
- (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)
-\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)
-
-(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)))
- ))
-
-\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 (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)
-\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))
- (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.
projects / elisp / tm.git / blobdiff