+(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)))
+ ))
+ ))
projects / elisp / tm.git / blobdiff