tm-vm.el

   1 ;;;
   2 ;;; tm-vm.el --- tm-MUA for VM
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;;
   6 ;;; Author:   MASUTANI Yasuhiro <masutani@me.es.osaka-u.ac.jp>
   7 ;;;           Kenji Wakamiya <wkenji@flab.fujitsu.co.jp>
   8 ;;;           MORIOKA Tomohiko <morioka@jaist.ac.jp>
   9 ;;;           Shuhei KOBAYASHI <shuhei@cmpt01.phys.tohoku.ac.jp>
  10 ;;;           Oscar Figueiredo <figueire@lspsun2.epfl.ch>
  11 ;;; modified by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
  12 ;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  13 ;;; Created: 1994/10/29
  14 ;;; Version: $Revision: 7.20 $
  15 ;;; Keywords: news, MIME, multimedia, multilingual, encoded-word
  16 ;;;
  17 ;;; This file is part of tm (Tools for MIME).
  18 ;;;
  19 ;;; Plese insert (require 'tm-vm) in your ~/.vm or ~/.emacs file.
  20 ;;;
  21 ;;; This program is free software; you can redistribute it and/or
  22 ;;; modify it under the terms of the GNU General Public License as
  23 ;;; published by the Free Software Foundation; either version 2, or
  24 ;;; (at your option) any later version.
  25 ;;;
  26 ;;; This program is distributed in the hope that it will be useful,
  27 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  28 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  29 ;;; General Public License for more details.
  30 ;;;
  31 ;;; You should have received a copy of the GNU General Public License
  32 ;;; along with This program.  If not, write to the Free Software
  33 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  34
  35 (require 'tm-view)
  36 (require 'vm)
  37
  38 (defconst tm-vm/RCS-ID
  39   "$Id: tm-vm.el,v 7.20 1995/11/21 09:43:00 morioka Exp $")
  40 (defconst tm-vm/version (get-version-string tm-vm/RCS-ID))
  41
  42 (define-key vm-mode-map "Z" 'tm-vm/view-message)
  43 (define-key vm-mode-map "T" 'tm-vm/decode-message-header)
  44 (define-key vm-mode-map "\et" 'tm-vm/toggle-preview-mode)
  45
  46
  47 ;;; @ for MIME encoded-words
  48 ;;;
  49
  50 (defvar tm-vm/use-tm-patch nil
  51   "Does not decode encoded-words in summary buffer if it is t.
  52 If you use tiny-mime patch for VM (by RIKITAKE Kenji
  53 <kenji@reseau.toyonaka.osaka.jp>), please set it t [tm-vm.el]")
  54
  55 (or tm-vm/use-tm-patch
  56     (progn
  57 ;;;
  58 (defvar tm-vm/chop-full-name-function 'tm-vm/default-chop-full-name)
  59 (setq vm-chop-full-name-function tm-vm/chop-full-name-function)
  60
  61 (defun tm-vm/default-chop-full-name (address)
  62   (let* ((ret (vm-default-chop-full-name address))
  63          (full-name (car ret))
  64          )
  65     (if (stringp full-name)
  66         (cons (mime-eword/decode-string full-name)
  67               (cdr ret))
  68       ret)))
  69
  70 (require 'vm-summary)
  71 (or (fboundp 'tm:vm-su-subject)
  72     (fset 'tm:vm-su-subject (symbol-function 'vm-su-subject))
  73     )
  74 (defun vm-su-subject (m)
  75   (mime-eword/decode-string (tm:vm-su-subject m))
  76   )
  77 ;;;
  78 ))
  79
  80 (defun tm-vm/decode-message-header (&optional count)
  81   "Decode MIME header of current message through tiny-mime.
  82 Numeric prefix argument COUNT means to decode the current message plus
  83 the next COUNT-1 messages.  A negative COUNT means decode the current
  84 message and the previous COUNT-1 messages.
  85 When invoked on marked messages (via vm-next-command-uses-marks),
  86 all marked messages are affected, other messages are ignored."
  87   (interactive "p")
  88   (or count (setq count 1))
  89   (vm-follow-summary-cursor)
  90   (vm-select-folder-buffer)
  91   (vm-check-for-killed-summary)
  92   (vm-error-if-folder-empty)
  93   (vm-error-if-folder-read-only)
  94   (let ((mlist (vm-select-marked-or-prefixed-messages count))
  95         (realm nil)
  96         (vlist nil)
  97         (vbufs nil))
  98     (save-excursion
  99       (while mlist
 100         (setq realm (vm-real-message-of (car mlist)))
 101         ;; Go to real folder of this message.
 102         ;; But maybe this message is already real message...
 103         (set-buffer (vm-buffer-of realm))
 104         (let ((buffer-read-only nil))
 105           (vm-save-restriction
 106            (narrow-to-region (vm-headers-of realm) (vm-text-of realm))
 107            (mime/decode-message-header))
 108           (let ((vm-message-pointer (list realm))
 109                 (last-command nil))
 110             (vm-discard-cached-data))
 111           ;; Mark each virtual and real message for later summary
 112           ;; update.
 113           (setq vlist (cons realm (vm-virtual-messages-of realm)))
 114           (while vlist
 115             (vm-mark-for-summary-update (car vlist))
 116             ;; Remember virtual and real folders related this message,
 117             ;; for later display update.
 118             (or (memq (vm-buffer-of (car vlist)) vbufs)
 119                 (setq vbufs (cons (vm-buffer-of (car vlist)) vbufs)))
 120             (setq vlist (cdr vlist)))
 121           (if (eq vm-flush-interval t)
 122               (vm-stuff-virtual-attributes realm)
 123             (vm-set-modflag-of realm t)))
 124         (setq mlist (cdr mlist)))
 125       ;; Update mail-buffers and summaries.
 126       (while vbufs
 127         (set-buffer (car vbufs))
 128         (vm-preview-current-message)
 129         (setq vbufs (cdr vbufs))))))
 130
 131
 132 ;;; @ automatic MIME preview
 133 ;;;
 134
 135 (defvar tm-vm/automatic-mime-preview t
 136   "If non-nil, show MIME processed article.")
 137
 138 (defun tm-vm/preview-current-message ()
 139   ;;; suggested by Simon Rowe <smr@robots.oxford.ac.uk>
 140   ;;;   (cf. [tm-eng:163])
 141   ;; Selecting a new mail message, but we're already displaying a mime
 142   ;; on in the window, make sure that the mail buffer is displayed.
 143   (if (get-buffer-window "*MIME-out*")
 144       (delete-window (get-buffer-window (get-buffer "*MIME-out*")))
 145     )
 146   (if (and tm-vm/automatic-mime-preview
 147            ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 148            ;;   1995/11/17 (cf.[tm-ja:1120])
 149            (display-buffer (current-buffer))
 150            (let* ((mp (car vm-message-pointer))
 151                   (ct  (vm-get-header-contents mp "Content-Type:"))
 152                   (cte (vm-get-header-contents
 153                         mp "Content-Transfer-Encoding:"))
 154                   )
 155              ;; Check if this message actually is a mime, or just a text
 156              ;; one sent by someone using PINE or similar.
 157              (and ct
 158                   (not (and (string= (car (mime/parse-Content-Type ct))
 159                                      "text/plain")
 160                             (member cte '("7bit" "8bit" "binary"))
 161                             ))))
 162            )
 163       (let ((win (selected-window)))
 164         (let ((pwin (and mime::article/preview-buffer
 165                          (get-buffer mime::article/preview-buffer)
 166                          (get-buffer-window mime::article/preview-buffer))))
 167           (if pwin
 168               (delete-window pwin)
 169             ))
 170         (vm-display nil nil
 171                     '(vm-next-message
 172                       vm-delete-message
 173                       vm-undelete-message
 174                       vm-scroll-forward vm-scroll-backward)
 175                     (list this-command 'reading-message))
 176         (vm-select-folder-buffer)
 177         (vm-display (current-buffer) t
 178                     '(vm-scroll-forward vm-scroll-backward)
 179                     (list this-command 'reading-message))
 180         (mime/viewer-mode)
 181         (run-hooks 'tm-vm/vm-select-message-hook)
 182         (select-window win)
 183         )
 184     ;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 185     ;;  1995/11/17
 186     (if (and mime::article/preview-buffer
 187              (get-buffer mime::article/preview-buffer))
 188         (kill-buffer mime::article/preview-buffer))
 189     (if tm-vm/automatic-mime-preview
 190         (let (buffer-read-only)
 191           (mime/decode-message-header)
 192           (run-hooks 'tm-vm/vm-select-message-hook)
 193           ))
 194     ))
 195
 196 (add-hook 'vm-select-message-hook 'tm-vm/preview-current-message)
 197 (add-hook 'vm-visit-folder-hook 'tm-vm/preview-current-message)
 198
 199 ;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 200 ;;      1995/11/14 (cf.[tm-eng:162])
 201 (defun tm-vm/scroll-forward ()
 202   (interactive)
 203   (if (not tm-vm/automatic-mime-preview)
 204       ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 205       ;;        1995/11/17 (cf.[tm-ja:1119])
 206       (progn
 207         (setq this-command 'vm-scroll-forward)
 208         (vm-scroll-forward))
 209     (let* ((summary-buffer (or vm-summary-buffer
 210                                (and (eq major-mode 'vm-summary-mode)
 211                                     (current-buffer))))
 212            (summary-win (get-buffer-window summary-buffer))
 213            (mail-buffer (save-excursion
 214                           (set-buffer summary-buffer)
 215                           vm-mail-buffer))
 216            (mail-win (get-buffer-window mail-buffer))
 217            (preview-buf (save-excursion
 218                           (set-buffer mail-buffer)
 219                           mime::article/preview-buffer))
 220            (preview-win (and preview-buf (get-buffer-window preview-buf)))
 221            )
 222       (if preview-win
 223           (progn
 224             (select-window preview-win)
 225             (if (pos-visible-in-window-p (point-max) preview-win)
 226                 (progn
 227                   (switch-to-buffer mail-buffer)
 228                   (goto-char (point-max))
 229                   (select-window summary-win))
 230               (scroll-up)
 231               (switch-to-buffer mail-buffer)
 232               (select-window summary-win))))
 233       ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 234       ;;        1995/11/17 (cf.[tm-ja:1119])
 235       (setq this-command 'vm-scroll-forward)
 236       (vm-scroll-forward)
 237       (save-excursion
 238         (set-buffer summary-buffer)
 239         (setq mail-win (get-buffer-window vm-mail-buffer)))
 240       ;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 241       ;;        1995/11/17
 242       (if (and mail-win
 243                mime::article/preview-buffer
 244                (get-buffer mime::article/preview-buffer))
 245           (progn
 246             (select-window mail-win)
 247             (switch-to-buffer mime::article/preview-buffer)
 248             (select-window summary-win)))
 249       )))
 250
 251 (defun tm-vm/scroll-backward ()
 252   (interactive)
 253   (if (not tm-vm/automatic-mime-preview)
 254       ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 255       ;;        1995/11/17 (cf.[tm-ja:1119])
 256       (progn
 257         (setq this-command 'vm-scroll-backward)
 258         (vm-scroll-backward nil))
 259     (let* ((summary-buffer (or vm-summary-buffer
 260                                (and (eq major-mode 'vm-summary-mode)
 261                                     (current-buffer))))
 262            (summary-win (get-buffer-window summary-buffer))
 263            (mail-buffer (save-excursion
 264                           (set-buffer summary-buffer)
 265                           vm-mail-buffer))
 266            (mail-win (get-buffer-window mail-buffer))
 267            (preview-buf (save-excursion
 268                           (set-buffer mail-buffer)
 269                           mime::article/preview-buffer))
 270            (preview-win (and preview-buf (get-buffer-window preview-buf)))
 271            )
 272       (if preview-win
 273           (progn
 274             (select-window preview-win)
 275             (if (pos-visible-in-window-p (point-min) preview-win)
 276                 (progn
 277                   (switch-to-buffer mail-buffer)
 278                   (goto-char (point-min))
 279                   (select-window summary-win))
 280               (scroll-down)
 281               (switch-to-buffer mail-buffer)
 282               (select-window summary-win))))
 283       ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 284       ;;        1995/11/17 (cf.[tm-ja:1119])
 285       (setq this-command 'vm-scroll-backward)
 286       (vm-scroll-backward nil)
 287       (save-excursion
 288         (set-buffer summary-buffer)
 289         (setq mail-win (get-buffer-window vm-mail-buffer)))
 290       (if (and mail-win
 291                mime::article/preview-buffer
 292                (get-buffer mime::article/preview-buffer))
 293           (progn
 294             (select-window mail-win)
 295             (goto-char (point-max))
 296             (switch-to-buffer mime::article/preview-buffer)
 297             (select-window summary-win)))
 298       )))
 299
 300 ;; 1995/11/16 by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 301 (defun tm-vm/expunge-folder ()
 302   (interactive)
 303   (let* ((summary-buf (or (and (eq major-mode 'vm-summary-mode)
 304                                (current-buffer))
 305                           vm-summary-buffer))
 306          (preview-buf (save-excursion
 307                         (set-buffer (save-excursion
 308                                       (set-buffer summary-buf)
 309                                       vm-mail-buffer))
 310                         mime::article/preview-buffer))
 311          (preview-win (and preview-buf
 312                            (get-buffer-window preview-buf)))
 313          (win (selected-window)))
 314
 315     (vm-expunge-folder)
 316     (if preview-win
 317         (save-excursion
 318           (set-buffer summary-buf)
 319           (set-buffer vm-mail-buffer)
 320           (if (eq (point-min) (point-max))
 321               (kill-buffer preview-buf))))
 322     ))
 323
 324 ;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 325 ;;      1995/11/14 (cf. [tm-eng:162])
 326 (defun tm-vm/quit ()
 327   (interactive)
 328   (save-excursion
 329     (vm-select-folder-buffer)
 330     (if (and mime::article/preview-buffer
 331              (get-buffer mime::article/preview-buffer))
 332         (kill-buffer mime::article/preview-buffer)))
 333   (vm-quit)
 334   )
 335
 336 (substitute-key-definition 'vm-scroll-forward
 337                            'tm-vm/scroll-forward vm-mode-map)
 338 (substitute-key-definition 'vm-scroll-backward
 339                            'tm-vm/scroll-backward vm-mode-map)
 340 (substitute-key-definition 'vm-expunge-folder
 341                            'tm-vm/expunge-folder vm-mode-map)
 342 (substitute-key-definition 'vm-quit
 343                            'tm-vm/quit vm-mode-map)
 344 ;; end
 345
 346
 347 (defun tm-vm/toggle-preview-mode ()
 348   (interactive)
 349   (if tm-vm/automatic-mime-preview
 350       (progn
 351         (setq tm-vm/automatic-mime-preview nil)
 352         (vm-select-folder-buffer)
 353         (vm-display (current-buffer) t
 354                     '(tm-vm/toggle-preview-mode)
 355                     '(tm-vm/toggle-preview-mode reading-message))
 356         )
 357     (setq tm-vm/automatic-mime-preview t)
 358     (let ((win (selected-window)))
 359       (vm-select-folder-buffer)
 360       (save-window-excursion
 361         (let* ((mp (car vm-message-pointer))
 362                (ct  (vm-get-header-contents mp "Content-Type:"))
 363                (cte (vm-get-header-contents mp "Content-Transfer-Encoding:"))
 364                )
 365           (mime/viewer-mode nil (mime/parse-Content-Type (or ct "")) cte)
 366           ))
 367       (vm-display mime::article/preview-buffer t
 368                   '(tm-vm/toggle-preview-mode)
 369                   '(tm-vm/toggle-preview-mode reading-message))
 370       (select-window win)
 371       )
 372     ))
 373
 374
 375 ;;; @ for tm-view
 376 ;;;
 377
 378 (defun tm-vm/quit-view-message ()
 379   "Quit MIME-viewer and go back to VM.
 380 This function is called by `mime-viewer/quit' command via
 381 `mime-viewer/quitting-method-alist'."
 382   (mime-viewer/kill-buffer)
 383   (if (get-buffer mime/output-buffer-name)
 384       (bury-buffer mime/output-buffer-name))
 385   (vm-select-folder-buffer)
 386   (vm-display (current-buffer) t '(mime-viewer/quit mime-viewer/up-content)
 387               '(mime-viewer/quit reading-message)))
 388
 389 (defun tm-vm/view-message ()
 390   "Decode and view MIME encoded message, under VM."
 391   (interactive)
 392   (vm-follow-summary-cursor)
 393   (vm-select-folder-buffer)
 394   (vm-check-for-killed-summary)
 395   (vm-error-if-folder-empty)
 396   (vm-display (current-buffer) t '(tm-vm/view-message)
 397               '(tm-vm/view-mesage reading-message))
 398   (let* ((mp (car vm-message-pointer))
 399          (ct  (vm-get-header-contents mp "Content-Type:"))
 400          (cte (vm-get-header-contents mp "Content-Transfer-Encoding:"))
 401          (exposed (= (point-min) (vm-start-of mp))))
 402     (save-restriction
 403       (vm-widen-page)
 404       ;; vm-widen-page hides exposed header if pages are delimited.
 405       ;; So, here we expose it again.
 406       (if exposed
 407           (narrow-to-region (vm-start-of mp) (point-max)))
 408       (select-window (vm-get-buffer-window (current-buffer)))
 409       (mime/viewer-mode nil
 410                         (mime/parse-Content-Type (or ct ""))
 411                         cte)
 412       )))
 413
 414 (set-alist 'mime-viewer/quitting-method-alist
 415            'vm-mode
 416            'tm-vm/quit-view-message)
 417
 418 (set-alist 'mime-viewer/quitting-method-alist
 419            'vm-virtual-mode
 420            'tm-vm/quit-view-message)
 421
 422
 423 ;;; @ for tm-partial
 424 ;;;
 425
 426 (call-after-loaded
 427  'tm-partial
 428  (function
 429   (lambda ()
 430     (set-atype 'mime/content-decoding-condition
 431                '((type . "message/partial")
 432                  (method . mime-article/grab-message/partials)
 433                  (major-mode . vm-mode)
 434                  (summary-buffer-exp . vm-summary-buffer)
 435                  ))
 436     (set-alist 'tm-partial/preview-article-method-alist
 437                'vm-mode
 438                (function
 439                 (lambda ()
 440                   (tm-vm/view-message)
 441                   )))
 442     )))
 443
 444
 445 ;;; @ for tm-edit
 446 ;;;
 447
 448 ;; 1995/11/9 by Shuhei KOBAYASHI <shuhei@cmpt01.phys.tohoku.ac.jp>
 449 ;;      (cf. [tm ML:1075])
 450 (defun tm-vm/insert-message (&optional message)
 451   (interactive)
 452   (let* (mail-yank-hooks
 453          (mail-citation-hook '(mime-editor/inserted-message-filter))
 454          (mail-reply-buffer vm-mail-buffer)
 455          )
 456     (if (null message)
 457         (call-interactively 'vm-yank-message)
 458       (vm-yank-message message))
 459     ))
 460
 461
 462 ;;; @@ for multipart/digest
 463 ;;;
 464
 465 (defun tm-vm/enclose-messages (mlist)
 466   "Enclose the messages in MLIST as multipart/digest.
 467 The resulting digest is inserted at point in the current buffer.
 468
 469 MLIST should be a list of message structs (real or virtual).
 470 These are the messages that will be enclosed."
 471   (if mlist
 472       (let ((digest (consp (cdr mlist)))
 473             m)
 474         (save-restriction
 475           (narrow-to-region (point) (point))
 476           (while mlist
 477             (setq m (vm-real-message-of (car mlist)))
 478             (mime-editor/insert-tag "message" "rfc822")
 479             (tm-vm/insert-message m)
 480             (goto-char (point-max))
 481             (setq mlist (cdr mlist)))
 482           (if digest
 483               (mime-editor/enclose-digest-region (point-min) (point-max)))
 484           ))))
 485
 486 (defun tm-vm/forward-message ()
 487   "Forward the current message to one or more recipients.
 488 You will be placed in a Mail mode buffer as you would with a
 489 reply, but you must fill in the To: header and perhaps the
 490 Subject: header manually."
 491   (interactive)
 492   (if (not (equal vm-forwarding-digest-type "rfc1521"))
 493       (vm-forward-message)
 494     (vm-follow-summary-cursor)
 495     (vm-select-folder-buffer)
 496     (vm-check-for-killed-summary)
 497     (vm-error-if-folder-empty)
 498     (if (eq last-command 'vm-next-command-uses-marks)
 499         (let ((vm-digest-send-type vm-forwarding-digest-type))
 500           (setq this-command 'vm-next-command-uses-marks)
 501           (command-execute 'tm-vm/send-digest))
 502       (let ((dir default-directory)
 503             (mp vm-message-pointer))
 504         (save-restriction
 505           (widen)
 506           (vm-mail-internal
 507            (format "forward of %s's note re: %s"
 508                    (vm-su-full-name (car vm-message-pointer))
 509                    (vm-su-subject (car vm-message-pointer)))
 510            nil
 511            (and vm-forwarding-subject-format
 512                 (let ((vm-summary-uninteresting-senders nil))
 513                   (vm-sprintf 'vm-forwarding-subject-format (car mp)))))
 514           (make-local-variable 'vm-forward-list)
 515           (setq vm-system-state 'forwarding
 516                 vm-forward-list (list (car mp))
 517                 default-directory dir)
 518           (goto-char (point-min))
 519           (re-search-forward
 520            (concat "^" (regexp-quote mail-header-separator) "\n") nil 0)
 521           (tm-vm/enclose-messages vm-forward-list)
 522           (mail-position-on-field "To"))
 523         ;; (run-hooks 'tm-vm/forward-message-hook) ; Is it necessary?
 524         (run-hooks 'vm-mail-mode-hook)))))
 525
 526 (defun tm-vm/send-digest (&optional prefix)
 527   "Send a digest of all messages in the current folder to recipients.
 528 The type of the digest is specified by the variable vm-digest-send-type.
 529 You will be placed in a Mail mode buffer as is usual with replies, but you
 530 must fill in the To: and Subject: headers manually.
 531
 532 If invoked on marked messages (via vm-next-command-uses-marks),
 533 only marked messages will be put into the digest."
 534   (interactive "P")
 535   (if (not (equal vm-digest-send-type "rfc1521"))
 536       (vm-send-digest prefix)
 537     (vm-select-folder-buffer)
 538     (vm-check-for-killed-summary)
 539     (vm-error-if-folder-empty)
 540     (let ((dir default-directory)
 541           (mp vm-message-pointer)
 542           (mlist (if (eq last-command 'vm-next-command-uses-marks)
 543                      (vm-select-marked-or-prefixed-messages 0)
 544                    vm-message-list))
 545           start)
 546       (save-restriction
 547         (widen)
 548         (vm-mail-internal (format "digest from %s" (buffer-name)))
 549         (setq vm-system-state 'forwarding
 550               vm-forward-list mlist
 551               default-directory dir)
 552         (goto-char (point-min))
 553         (re-search-forward (concat "^" (regexp-quote mail-header-separator)
 554                                    "\n"))
 555         (goto-char (match-end 0))
 556         (setq start (point)
 557               mp mlist)
 558         (vm-unsaved-message "Building %s digest..." vm-digest-send-type)
 559         (tm-vm/enclose-messages mlist)
 560         (goto-char start)
 561         (setq mp mlist)
 562         (if prefix
 563           (progn
 564             (mime-editor/insert-tag "text" "plain")
 565             (vm-unsaved-message "Building digest preamble...")
 566             (while mp
 567               (let ((vm-summary-uninteresting-senders nil))
 568                 (insert (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n"))
 569               (if vm-digest-center-preamble
 570                   (progn
 571                     (forward-char -1)
 572                     (center-line)
 573                     (forward-char 1)))
 574               (setq mp (cdr mp)))))
 575         (mail-position-on-field "To")
 576         (message "Building %s digest... done" vm-digest-send-type)))
 577     ;; (run-hooks 'tm-vm/send-digest-hook) ; Is it necessary?
 578     (run-hooks 'vm-mail-mode-hook)))
 579
 580
 581 ;;; @@ setting
 582 ;;;
 583
 584 (substitute-key-definition 'vm-forward-message
 585                            'tm-vm/forward-message vm-mode-map)
 586 (substitute-key-definition 'vm-send-digest
 587                            'tm-vm/send-digest vm-mode-map)
 588
 589 (call-after-loaded
 590  'tm-edit
 591  (function
 592   (lambda ()
 593     (set-alist 'mime-editor/message-inserter-alist
 594                'mail-mode (function tm-vm/insert-message))
 595     )))
 596
 597 (call-after-loaded
 598  'mime-setup
 599  (function
 600   (lambda ()
 601     ;;(remove-hook 'mail-mode-hook 'mime/editor-mode)
 602     ;;(add-hook 'vm-mail-mode-hook 'mime/editor-mode)
 603     (setq vm-forwarding-digest-type "rfc1521")
 604     (setq vm-digest-send-type "rfc1521")
 605     )))
 606
 607
 608 ;;; @ for BBDB
 609 ;;;
 610
 611 (call-after-loaded
 612  'bbdb-vm
 613  (function
 614   (lambda ()
 615     (or (fboundp 'tm:bbdb/vm-update-record)
 616         (fset 'tm:bbdb/vm-update-record
 617               (symbol-function 'bbdb/vm-update-record))
 618         )
 619     (defun bbdb/vm-update-record (&optional offer-to-create)
 620       (vm-select-folder-buffer)
 621       (let ((vm-mail-buffer
 622              (if (and mime::article/preview-buffer
 623                       (get-buffer mime::article/preview-buffer))
 624                  mime::article/preview-buffer
 625                (current-buffer)
 626                ))
 627             (bbdb/vm-update-record-recursive
 628              (boundp 'bbdb/vm-update-record-recursive))
 629             bbdb/vm-update-record-recursive ret)
 630         (let ((bbdb/vm-update-record-answer
 631                (if (boundp 'bbdb/vm-update-record-answer)
 632                    (setq bbdb/vm-update-record-answer
 633                          (or bbdb/vm-update-record-answer
 634                              (tm:bbdb/vm-update-record)
 635                              ))
 636                  (setq ret (tm:bbdb/vm-update-record))
 637                  nil)))
 638           (or bbdb/vm-update-record-answer ret)
 639           )))
 640     (defun tm-vm/bbdb-update-record (&optional offer-to-create)
 641       (let ((vm-mail-buffer (current-buffer)))
 642         (tm:bbdb/vm-update-record offer-to-create)
 643         ))
 644     (remove-hook 'vm-select-message-hook 'bbdb/vm-update-record)
 645     (remove-hook 'vm-show-message-hook 'bbdb/vm-update-record)
 646     (add-hook 'tm-vm/select-message-hook 'tm-vm/update-record)
 647     )))
 648
 649
 650 ;;; @ end
 651 ;;;
 652
 653 (provide 'tm-vm)