--- /dev/null
+;;;
+;;; tm-bbdb.el --- tm shred module for BBDB
+;;;
+;;; Copyright (C) 1995 KOBAYASHI Shuhei <shuhei@cmpt01.phys.tohoku.ac.jp>
+;;;
+;;; Author: KOBAYASHI Shuhei <shuhei@cmpt01.phys.tohoku.ac.jp>
+;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;;; Version: $Id: tm-bbdb.el,v 2.0 1996/01/23 04:34:12 morioka Exp $
+;;; Keywords: mail, news, MIME, multimedia, multilingual, BBDB
+;;;
+;;; 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. If not, write to the Free Software
+;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;
+;;; Code:
+
+(require 'bbdb)
+(require 'tl-822)
+(require 'tm-ew-d)
+
+(defun tm-bbdb/extract-address-components (str)
+ (let* ((ret (rfc822/extract-address-components str))
+ (phrase (car ret))
+ (address (cdr ret))
+ (methods tm-bbdb/canonicalize-full-name-methods))
+ (while (and phrase methods)
+ (setq phrase (funcall (car methods) phrase)
+ methods (cdr methods)))
+ (cons phrase address)
+ ))
+
+(fset 'mail-extract-address-components
+ (symbol-function 'tm-bbdb/extract-address-components))
+(provide 'mail-extr)
+
+(or (fboundp 'tm:bbdb-extract-field-value)
+ (progn
+ ;; (require 'bbdb-hooks) ; not provided.
+ (or (fboundp 'bbdb-extract-field-value)
+ (load "bbdb-hooks"))
+ (fset 'tm:bbdb-extract-field-value
+ (symbol-function 'bbdb-extract-field-value))
+ (defun bbdb-extract-field-value (field)
+ (let ((value (rfc822/get-field-body field)))
+ (and value
+ (mime-eword/decode-string value))))
+ ))
+
+
+;;; @ full-name canonicalization methods
+;;;
+
+(defun tm-bbdb/canonicalize-spaces (str)
+ (let (dest)
+ (while (string-match "\\s +" str)
+ (setq dest (cons (substring str 0 (match-beginning 0)) dest))
+ (setq str (substring str (match-end 0)))
+ )
+ (or (string= str "")
+ (setq dest (cons str dest)))
+ (setq dest (nreverse dest))
+ (mapconcat 'identity dest " ")
+ ))
+
+(defun tm-bbdb/canonicalize-dots (str)
+ (let (dest)
+ (while (string-match "\\." str)
+ (setq dest (cons (substring str 0 (match-end 0)) dest))
+ (setq str (substring str (match-end 0)))
+ )
+ (or (string= str "")
+ (setq dest (cons str dest)))
+ (setq dest (nreverse dest))
+ (mapconcat 'identity dest " ")
+ ))
+
+(defvar tm-bbdb/canonicalize-full-name-methods nil)
+
+(setq tm-bbdb/canonicalize-full-name-methods
+ '(mime-eword/decode-string
+ tm-bbdb/canonicalize-dots
+ tm-bbdb/canonicalize-spaces))
+
+
+;;; @ BBDB functions for mime/viewer-mode
+;;;
+
+(defvar tm-bbdb/auto-create-p nil)
+
+(defun tm-bbdb/update-record (&optional offer-to-create)
+ "Return the record corresponding to the current MIME previewing message.
+Creating or modifying it as necessary. A record will be created if
+tm-bbdb/auto-create-p is non-nil, or if OFFER-TO-CREATE is non-nil and
+the user confirms the creation."
+ (save-excursion
+ (and mime::article/preview-buffer
+ (get-buffer mime::article/preview-buffer)
+ (set-buffer mime::article/preview-buffer))
+ (if bbdb-use-pop-up
+ (tm-bbdb/pop-up-bbdb-buffer offer-to-create)
+ (let ((from (rfc822/get-field-body "From")))
+ (if (or (null from)
+ (string-match (bbdb-user-mail-names)
+ (car
+ (cdr
+ ;; (tm-bbdb/extract-address-components from)
+ (mail-extract-address-components from)
+ ))))
+ (setq from (or (rfc822/get-field-body "To")
+ from)))
+ (if from
+ (bbdb-annotate-message-sender
+ from t
+ (or (bbdb-invoke-hook-for-value tm-bbdb/auto-create-p)
+ offer-to-create)
+ offer-to-create))
+ ))))
+
+(defun tm-bbdb/annotate-sender (string)
+ "Add a line to the end of the Notes field of the BBDB record
+corresponding to the sender of this message."
+ (interactive
+ (list (if bbdb-readonly-p
+ (error "The Insidious Big Brother Database is read-only.")
+ (read-string "Comments: "))))
+ (bbdb-annotate-notes (tm-bbdb/update-record t) string))
+
+(defun tm-bbdb/edit-notes (&optional arg)
+ "Edit the notes field or (with a prefix arg) a user-defined field
+of the BBDB record corresponding to the sender of this message."
+ (interactive "P")
+ (let ((record (or (tm-bbdb/update-record t)
+ (error ""))))
+ (bbdb-display-records (list record))
+ (if arg
+ (bbdb-record-edit-property record nil t)
+ (bbdb-record-edit-notes record t))))
+
+(defun tm-bbdb/show-sender ()
+ "Display the contents of the BBDB for the sender of this message.
+This buffer will be in bbdb-mode, with associated keybindings."
+ (interactive)
+ (let ((record (tm-bbdb/update-record t)))
+ (if record
+ (bbdb-display-records (list record))
+ (error "unperson"))))
+
+(defun tm-bbdb/pop-up-bbdb-buffer (&optional offer-to-create)
+ "Make the *BBDB* buffer be displayed along with the MIME preview window(s),
+displaying the record corresponding to the sender of the current message."
+ (bbdb-pop-up-bbdb-buffer
+ (function (lambda (w)
+ (let ((b (current-buffer)))
+ (set-buffer (window-buffer w))
+ (prog1 (eq major-mode 'mime/viewer-mode)
+ (set-buffer b))))))
+ (let ((bbdb-gag-messages t)
+ (bbdb-use-pop-up nil)
+ (bbdb-electric-p nil))
+ (let ((record (tm-bbdb/update-record offer-to-create))
+ (bbdb-elided-display (bbdb-pop-up-elided-display))
+ (b (current-buffer)))
+ (bbdb-display-records (if record (list record) nil))
+ (set-buffer b)
+ record)))
+
+
+;;; @ end
+;;;
+
+(provide 'tm-bbdb)
+
+(run-hooks 'tm-bbdb-load-hook)
+
+;;; end of tm-bbdb.el
;;; Oscar Figueiredo <figueire@lspsun2.epfl.ch>
;;; modified by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
;;; and ISHIHARA Akito <aki@bpel.tutics.tut.ac.jp>
-;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;;; Maintainer: Shuhei KOBAYASHI <shuhei@cmpt01.phys.tohoku.ac.jp>
;;; Created: 1994/10/29
-;;; Version: $Revision: 7.37 $
+;;; Version: $Revision: 7.39 $
;;; Keywords: mail, MIME, multimedia, multilingual, encoded-word
;;;
;;; This file is part of tm (Tools for MIME).
(require 'vm)
(defconst tm-vm/RCS-ID
- "$Id: tm-vm.el,v 7.37 1995/12/18 19:25:24 morioka Exp $")
+ "$Id: tm-vm.el,v 7.39 1996/01/23 04:46:54 morioka Exp $")
(defconst tm-vm/version (get-version-string tm-vm/RCS-ID))
(define-key vm-mode-map "Z" 'tm-vm/view-message)
(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))
+ )
;;;
))
(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 ()
- ;;; suggested by Simon Rowe <smr@robots.oxford.ac.uk>
- ;;; (cf. [tm-eng:163])
- ;; Selecting a new mail message, but we're already displaying a mime
- ;; on in the window, make sure that the mail buffer is displayed.
- (vm-save-buffer-excursion
- (if (get-buffer-window mime/output-buffer-name)
- (delete-window (get-buffer-window (get-buffer mime/output-buffer-name)))
- )
- ;; fixed by Shuhei KOBAYASHI <shuhei@cmpt01.phys.tohoku.ac.jp>
- ;; 1995/12/4 (cf. [tm-ja:1190])
- (if (and vm-message-pointer tm-vm/automatic-mime-preview
- ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
- ;; 1995/11/17 (cf. [tm-ja:1120])
- (display-buffer (current-buffer))
- (let* ((mp (car vm-message-pointer))
- (ct (vm-get-header-contents mp "Content-Type:"))
- (cte (vm-get-header-contents
- mp "Content-Transfer-Encoding:"))
- )
- ;; Check if this message actually is a mime, or just a text
- ;; one sent by someone using PINE or similar.
- (and ct
- (not (and (string= (car (mime/parse-Content-Type ct))
- "text/plain")
- (member cte '("7bit" "8bit" "binary"))
- ))))
- )
- (let ((win (selected-window)) buf)
- (setq buf (window-buffer win))
- (let ((pwin (and mime::article/preview-buffer
- (get-buffer mime::article/preview-buffer)
- (get-buffer-window mime::article/preview-buffer))))
- (if (and pwin
- (not (eq win pwin)))
- (delete-window pwin)
- ))
- (vm-display nil nil
- '(vm-next-message
- vm-previous-message
- vm-delete-message
- vm-undelete-message
- vm-scroll-forward vm-scroll-backward)
- (list this-command 'reading-message))
- (setq win (get-buffer-window buf))
- (if win
- (select-window win)
- )
- (save-window-excursion
- (vm-select-folder-buffer)
- (setq win (get-buffer-window (current-buffer)))
- ;; (vm-display (current-buffer) t
- ;; '(vm-scroll-forward vm-scroll-backward)
- ;; (list this-command 'reading-message))
- ;; (select-window (get-buffer-window (current-buffer)))
- (mime/viewer-mode)
- (setq buf (current-buffer))
- )
- (set-window-buffer win buf)
- ;;(select-window win)
- )
- ;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
- ;; 1995/11/17
- (if (and mime::article/preview-buffer
- (get-buffer mime::article/preview-buffer))
- (kill-buffer mime::article/preview-buffer))
- (if tm-vm/automatic-mime-preview
- (let (buffer-read-only)
- (mime/decode-message-header)
- ))
- ))
+ ;; 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
+ (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)
(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
+;;;
-;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
-;; 1995/11/14 (cf.[tm-eng:162])
+(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")
- (if (not tm-vm/automatic-mime-preview)
- ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
- ;; 1995/11/17 (cf.[tm-ja:1119])
- (progn
- (setq this-command 'vm-scroll-forward)
- (vm-scroll-forward arg))
- (let* ((summary-buffer (or vm-summary-buffer
- (and (eq major-mode 'vm-summary-mode)
- (current-buffer))))
- (summary-win (get-buffer-window summary-buffer))
- (mail-buffer (save-excursion
- (set-buffer summary-buffer)
- vm-mail-buffer))
- (mail-win (get-buffer-window mail-buffer))
- (preview-buf (save-excursion
- (set-buffer mail-buffer)
- mime::article/preview-buffer))
- (preview-win (and preview-buf (get-buffer-window preview-buf)))
- )
- (if preview-win
- (progn
- (select-window preview-win)
- (if (pos-visible-in-window-p (point-max) preview-win)
- (progn
- (switch-to-buffer mail-buffer)
- (goto-char (point-max))
- (select-window summary-win))
- (scroll-up)
- (switch-to-buffer mail-buffer)
- (select-window summary-win))))
- ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
- ;; 1995/11/17 (cf.[tm-ja:1119])
- (setq this-command 'vm-scroll-forward)
- (let ((vm-inhibit-startup-message t))
- (vm-scroll-forward arg))
- (save-excursion
- (set-buffer summary-buffer)
- (setq mail-win (get-buffer-window vm-mail-buffer)))
- ;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
- ;; 1995/11/17
- (if (and mail-win
- mime::article/preview-buffer
- (get-buffer mime::article/preview-buffer))
- (progn
- (select-window mail-win)
- (switch-to-buffer mime::article/preview-buffer)
- (select-window summary-win)))
+ (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
+ (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")
- (if (not tm-vm/automatic-mime-preview)
- ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
- ;; 1995/11/17 (cf.[tm-ja:1119])
- (progn
- (setq this-command 'vm-scroll-backward)
- (vm-scroll-backward arg))
- (let* ((summary-buffer (or vm-summary-buffer
- (and (eq major-mode 'vm-summary-mode)
- (current-buffer))))
- (summary-win (get-buffer-window summary-buffer))
- (mail-buffer (save-excursion
- (set-buffer summary-buffer)
- vm-mail-buffer))
- (mail-win (get-buffer-window mail-buffer))
- (preview-buf (save-excursion
- (set-buffer mail-buffer)
- mime::article/preview-buffer))
- (preview-win (and preview-buf (get-buffer-window preview-buf)))
- )
- (if preview-win
- (progn
- (select-window preview-win)
- (if (pos-visible-in-window-p (point-min) preview-win)
- (progn
- (switch-to-buffer mail-buffer)
- (goto-char (point-min))
- (select-window summary-win))
- (scroll-down)
- (switch-to-buffer mail-buffer)
- (select-window summary-win))))
- ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
- ;; 1995/11/17 (cf.[tm-ja:1119])
- (setq this-command 'vm-scroll-backward)
- (let ((vm-inhibit-startup-message t))
- (vm-scroll-backward arg))
- (save-excursion
- (set-buffer summary-buffer)
- (setq mail-win (get-buffer-window vm-mail-buffer)))
- (if (and mail-win
- mime::article/preview-buffer
- (get-buffer mime::article/preview-buffer))
- (progn
- (select-window mail-win)
- (switch-to-buffer mime::article/preview-buffer)
- (select-window summary-win)))
+ (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))
+ ))))
)))
-(defun tm-vm/over-to-previous-method ()
- (set-buffer mime::preview/article-buffer)
- (setq this-command 'vm-previous-message)
- (let (buf)
- (save-window-excursion
- (vm-previous-message 1 nil t)
- (setq buf
- (if (and mime::article/preview-buffer
- (get-buffer mime::article/preview-buffer))
- mime::article/preview-buffer
- (current-buffer)
- ))
- )
- (set-window-buffer (selected-window) buf)
- ))
-
-(defun tm-vm/over-to-next-method ()
- (set-buffer mime::preview/article-buffer)
- (setq this-command 'vm-next-message)
- (let (buf)
- (save-window-excursion
- (vm-next-message 1 nil t)
- (setq buf
- (if (and mime::article/preview-buffer
- (get-buffer mime::article/preview-buffer)
- )
- mime::article/preview-buffer
- (current-buffer)
- ))
- )
- (set-window-buffer (selected-window) buf)
- ))
-
-(set-alist 'mime-viewer/over-to-previous-method-alist
- 'vm-mode 'tm-vm/over-to-previous-method)
-(set-alist 'mime-viewer/over-to-next-method-alist
- 'vm-mode 'tm-vm/over-to-next-method)
-(set-alist 'mime-viewer/over-to-previous-method-alist
- 'vm-virtual-mode 'tm-vm/over-to-previous-method)
-(set-alist 'mime-viewer/over-to-next-method-alist
- 'vm-virtual-mode 'tm-vm/over-to-next-method)
-
-;; 1995/11/16 by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
-(defun tm-vm/expunge-folder ()
+;;; based on vm-beginning-of-message [vm-page.el]
+(defun tm-vm/beginning-of-message ()
+ "Moves to the beginning of the current message."
(interactive)
- (let* ((summary-buf (or (and (eq major-mode 'vm-summary-mode)
- (current-buffer))
- vm-summary-buffer))
- (preview-buf (save-excursion
- (set-buffer (save-excursion
- (set-buffer summary-buf)
- vm-mail-buffer))
- mime::article/preview-buffer))
- (preview-win (and preview-buf
- (get-buffer-window preview-buf)))
- (win (selected-window)))
-
- (vm-expunge-folder)
- (if preview-win
- (save-excursion
- (set-buffer summary-buf)
- (set-buffer vm-mail-buffer)
- (if (eq (point-min) (point-max))
- (kill-buffer preview-buf))))
- ))
+ (if (not (tm-vm/system-state))
+ (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))
+ (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)))
-;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
-;; 1995/11/14 (cf. [tm-eng:162])
+;;; based on vm-quit [vm-folder.el]
(defun tm-vm/quit ()
(interactive)
(save-excursion
(if (and mime::article/preview-buffer
(get-buffer mime::article/preview-buffer))
(kill-buffer mime::article/preview-buffer)))
- (vm-quit)
- )
+ (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-expunge-folder
- 'tm-vm/expunge-folder 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)
-;; end
-
-(defun tm-vm/toggle-preview-mode ()
- (interactive)
- (if tm-vm/automatic-mime-preview
- (progn
- (setq tm-vm/automatic-mime-preview nil)
- (vm-select-folder-buffer)
- (vm-display (current-buffer) t
- '(tm-vm/toggle-preview-mode)
- '(tm-vm/toggle-preview-mode reading-message))
- )
- (setq tm-vm/automatic-mime-preview t)
- (let ((win (selected-window)))
- (vm-select-folder-buffer)
- (save-window-excursion
- (let* ((mp (car vm-message-pointer))
- (ct (vm-get-header-contents mp "Content-Type:"))
- (cte (vm-get-header-contents mp "Content-Transfer-Encoding:"))
- )
- (mime/viewer-mode nil (mime/parse-Content-Type (or ct "")) cte)
- ))
- (vm-display mime::article/preview-buffer t
- '(tm-vm/toggle-preview-mode)
- '(tm-vm/toggle-preview-mode reading-message))
- (select-window win)
- )
- ))
+;;; 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)
+\f
;;; @ for tm-view
;;;
"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)))
+ (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/mother-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."
(run-hooks 'tm-vm/send-digest-hook)
(run-hooks 'vm-mail-mode-hook)))
-
-;;; @@ setting
-;;;
-
(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)
+;;; @@ for message/rfc822
+;;;
+\f
+
+;;; @@ setting
+;;;
+
(defvar tm-vm/use-xemacs-popup-menu t)
;;; modified by Steven L. Baur <steve@miranova.com>
;;;
(call-after-loaded
- 'bbdb-vm
+ '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))
- )
+ (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)
- (let ((vm-mail-buffer
- (if (and mime::article/preview-buffer
- (get-buffer mime::article/preview-buffer))
- mime::article/preview-buffer
- (current-buffer)
- ))
- (bbdb/vm-update-record-recursive
- (boundp 'bbdb/vm-update-record-recursive))
- bbdb/vm-update-record-recursive ret)
- (let ((bbdb/vm-update-record-answer
- (if (boundp 'bbdb/vm-update-record-answer)
- (setq bbdb/vm-update-record-answer
- (or bbdb/vm-update-record-answer
- (tm:bbdb/vm-update-record)
- ))
- (setq ret (tm:bbdb/vm-update-record))
- nil)))
- (or bbdb/vm-update-record-answer ret)
- )))
- (defun tm-vm/bbdb-update-record (&optional offer-to-create)
- (let ((vm-mail-buffer (current-buffer)))
- (tm:bbdb/vm-update-record offer-to-create)
- ))
+ (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 'tm-vm/bbdb-update-record)
+ (add-hook 'tm-vm/select-message-hook 'bbdb/vm-update-record)
)))
projects / elisp / tm.git / commitdiff