X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=tm-vm.el;h=962cc18f5652ea575e6ed1d467254f52cc06670f;hb=3fe76b044cf6350e4fddadbc8e3c12af0a97866b;hp=acc728cad4d5d5a2d8fe012a2b56998a5b403aaa;hpb=0f272975736cf4782907fb75f5efedb15ec6ea22;p=elisp%2Ftm.git diff --git a/tm-vm.el b/tm-vm.el index acc728c..962cc18 100644 --- a/tm-vm.el +++ b/tm-vm.el @@ -1,49 +1,45 @@ -;;; -;;; tm-vm.el --- tm-MUA for VM -;;; -;;; Copyright (C) 1994 MASUTANI Yasuhiro -;;; Copyright (C) 1995 WAKAMIYA Kenji -;;; Copyright (C) 1995,1996 KOBAYASHI Shuhei -;;; Copyright (C) 1996 Oscar Figueiredo -;;; -;;; Author: MASUTANI Yasuhiro -;;; Kenji Wakamiya -;;; MORIOKA Tomohiko -;;; Shuhei KOBAYASHI -;;; Oscar Figueiredo -;;; modified by SHIONO Jun'ichi -;;; ISHIHARA Akito -;;; Rob Kooper -;;; Maintainer: Shuhei KOBAYASHI -;;; Created: 1994/10/29 -;;; Version: $Revision: 7.50 $ -;;; Keywords: mail, MIME, multimedia, multilingual, encoded-word -;;; -;;; This file is part of tm (Tools for MIME). -;;; -;;; Plese insert `(require 'tm-vm)' in your ~/.vm file. -;;; -;;; This program is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation; either version 2, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with This program. If not, write to the Free Software -;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;; +;;; 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: (require 'tm-view) (require 'vm) (defconst tm-vm/RCS-ID - "$Id: tm-vm.el,v 7.50 1996/04/14 00:21: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) @@ -105,7 +101,7 @@ If you use tiny-mime patch for VM (by RIKITAKE Kenji )) (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. @@ -245,7 +241,8 @@ tm-vm uses `vm-select-message-hook', use this hook instead.") (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)) )) @@ -564,12 +561,23 @@ tm-vm uses `vm-select-message-hook', use this hook instead.") ;;; @@ vm-yank-message ;;; ;; 1996/3/28 by Oscar Figueiredo -(defun vm-yank-message (message) + +(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. @@ -596,68 +604,199 @@ vm-included-text-prefix is prepended to every yanked line." prompt (last-command last-command) (this-command this-command)) - (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)))) - (if (not (bufferp vm-mail-buffer)) - (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)))))) + (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 @@ -751,7 +890,7 @@ 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) +(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. @@ -759,6 +898,7 @@ 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)) @@ -768,6 +908,21 @@ These are the messages that will be enclosed." (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))) )))) @@ -812,7 +967,7 @@ Subject: header manually." (run-hooks 'tm-vm/forward-message-hook) (run-hooks 'vm-mail-mode-hook))))) -(defun tm-vm/send-digest (&optional prefix) +(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 @@ -822,45 +977,26 @@ If invoked on marked messages (via vm-next-command-uses-marks), only marked messages will be put into the digest." (interactive "P") (if (not (equal vm-digest-send-type "rfc1521")) - (vm-send-digest prefix) + (vm-send-digest arg) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (let ((dir default-directory) - (mp vm-message-pointer) - (mlist (if (eq last-command 'vm-next-command-uses-marks) - (vm-select-marked-or-prefixed-messages 0) - vm-message-list)) + (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 - vm-forward-list mlist default-directory dir) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (goto-char (match-end 0)) - (setq start (point) - mp mlist) (vm-unsaved-message "Building %s digest..." vm-digest-send-type) - (tm-vm/enclose-messages mlist) - (goto-char start) - (setq mp mlist) - (if prefix - (progn - (mime-editor/insert-tag "text" "plain") - (vm-unsaved-message "Building digest preamble...") - (while mp - (let ((vm-summary-uninteresting-senders nil)) - (insert (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n")) - (if vm-digest-center-preamble - (progn - (forward-char -1) - (center-line) - (forward-char 1))) - (setq mp (cdr mp))))) + (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) @@ -870,9 +1006,6 @@ only marked messages will be put into the digest." 'tm-vm/forward-message vm-mode-map) (substitute-key-definition 'vm-send-digest 'tm-vm/send-digest vm-mode-map) - -;;; @@ for message/rfc822 -;;; ;;; @@ setting @@ -900,6 +1033,12 @@ only marked messages will be put into the digest." (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)