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.25 $
  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.25 1995/12/04 23:44:47 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/output-buffer-name)
 144       (delete-window (get-buffer-window (get-buffer mime/output-buffer-name)))
 145     )
 146   ;; fixed by Shuhei KOBAYASHI <shuhei@cmpt01.phys.tohoku.ac.jp>
 147   ;;    1995/12/4 (cf. [tm-ja:1190])
 148   (if (and vm-message-pointer tm-vm/automatic-mime-preview
 149            ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 150            ;;   1995/11/17 (cf. [tm-ja:1120])
 151            (display-buffer (current-buffer))
 152            (let* ((mp (car vm-message-pointer))
 153                   (ct  (vm-get-header-contents mp "Content-Type:"))
 154                   (cte (vm-get-header-contents
 155                         mp "Content-Transfer-Encoding:"))
 156                   )
 157              ;; Check if this message actually is a mime, or just a text
 158              ;; one sent by someone using PINE or similar.
 159              (and ct
 160                   (not (and (string= (car (mime/parse-Content-Type ct))
 161                                      "text/plain")
 162                             (member cte '("7bit" "8bit" "binary"))
 163                             ))))
 164            )
 165       (let ((win (selected-window)))
 166         (let ((pwin (and mime::article/preview-buffer
 167                          (get-buffer mime::article/preview-buffer)
 168                          (get-buffer-window mime::article/preview-buffer))))
 169           (if (and pwin
 170                    (not (eq win pwin)))
 171               (delete-window pwin)
 172             ))
 173         (vm-display nil nil
 174                     '(vm-next-message
 175                       vm-previous-message
 176                       vm-delete-message
 177                       vm-undelete-message
 178                       vm-scroll-forward vm-scroll-backward)
 179                     (list this-command 'reading-message))
 180         (vm-select-folder-buffer)
 181         (vm-display (current-buffer) t
 182                     '(vm-scroll-forward vm-scroll-backward)
 183                     (list this-command 'reading-message))
 184         (select-window (get-buffer-window (current-buffer)))
 185         (mime/viewer-mode)
 186         (run-hooks 'tm-vm/vm-select-message-hook)
 187         (select-window win)
 188         )
 189     ;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 190     ;;  1995/11/17
 191     (if (and mime::article/preview-buffer
 192              (get-buffer mime::article/preview-buffer))
 193         (kill-buffer mime::article/preview-buffer))
 194     (if tm-vm/automatic-mime-preview
 195         (let (buffer-read-only)
 196           (mime/decode-message-header)
 197           (run-hooks 'tm-vm/vm-select-message-hook)
 198           ))
 199     ))
 200
 201 (add-hook 'vm-select-message-hook 'tm-vm/preview-current-message)
 202
 203 (defun tm-vm/visit-folder-function ()
 204   (tm-vm/preview-current-message)
 205   (and vm-mail-buffer (set-buffer vm-mail-buffer))
 206   )
 207
 208 (add-hook 'vm-visit-folder-hook 'tm-vm/visit-folder-function)
 209
 210 ;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 211 ;;      1995/11/14 (cf.[tm-eng:162])
 212 (defun tm-vm/scroll-forward (&optional arg)
 213   (interactive "P")
 214   (if (not tm-vm/automatic-mime-preview)
 215       ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 216       ;;        1995/11/17 (cf.[tm-ja:1119])
 217       (progn
 218         (setq this-command 'vm-scroll-forward)
 219         (vm-scroll-forward arg))
 220     (let* ((summary-buffer (or vm-summary-buffer
 221                                (and (eq major-mode 'vm-summary-mode)
 222                                     (current-buffer))))
 223            (summary-win (get-buffer-window summary-buffer))
 224            (mail-buffer (save-excursion
 225                           (set-buffer summary-buffer)
 226                           vm-mail-buffer))
 227            (mail-win (get-buffer-window mail-buffer))
 228            (preview-buf (save-excursion
 229                           (set-buffer mail-buffer)
 230                           mime::article/preview-buffer))
 231            (preview-win (and preview-buf (get-buffer-window preview-buf)))
 232            )
 233       (if preview-win
 234           (progn
 235             (select-window preview-win)
 236             (if (pos-visible-in-window-p (point-max) preview-win)
 237                 (progn
 238                   (switch-to-buffer mail-buffer)
 239                   (goto-char (point-max))
 240                   (select-window summary-win))
 241               (scroll-up)
 242               (switch-to-buffer mail-buffer)
 243               (select-window summary-win))))
 244       ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 245       ;;        1995/11/17 (cf.[tm-ja:1119])
 246       (setq this-command 'vm-scroll-forward)
 247       (vm-scroll-forward arg)
 248       (save-excursion
 249         (set-buffer summary-buffer)
 250         (setq mail-win (get-buffer-window vm-mail-buffer)))
 251       ;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 252       ;;        1995/11/17
 253       (if (and mail-win
 254                mime::article/preview-buffer
 255                (get-buffer mime::article/preview-buffer))
 256           (progn
 257             (select-window mail-win)
 258             (switch-to-buffer mime::article/preview-buffer)
 259             (select-window summary-win)))
 260       )))
 261
 262 (defun tm-vm/scroll-backward (&optional arg)
 263   (interactive "P")
 264   (if (not tm-vm/automatic-mime-preview)
 265       ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 266       ;;        1995/11/17 (cf.[tm-ja:1119])
 267       (progn
 268         (setq this-command 'vm-scroll-backward)
 269         (vm-scroll-backward arg))
 270     (let* ((summary-buffer (or vm-summary-buffer
 271                                (and (eq major-mode 'vm-summary-mode)
 272                                     (current-buffer))))
 273            (summary-win (get-buffer-window summary-buffer))
 274            (mail-buffer (save-excursion
 275                           (set-buffer summary-buffer)
 276                           vm-mail-buffer))
 277            (mail-win (get-buffer-window mail-buffer))
 278            (preview-buf (save-excursion
 279                           (set-buffer mail-buffer)
 280                           mime::article/preview-buffer))
 281            (preview-win (and preview-buf (get-buffer-window preview-buf)))
 282            )
 283       (if preview-win
 284           (progn
 285             (select-window preview-win)
 286             (if (pos-visible-in-window-p (point-min) preview-win)
 287                 (progn
 288                   (switch-to-buffer mail-buffer)
 289                   (goto-char (point-min))
 290                   (select-window summary-win))
 291               (scroll-down)
 292               (switch-to-buffer mail-buffer)
 293               (select-window summary-win))))
 294       ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 295       ;;        1995/11/17 (cf.[tm-ja:1119])
 296       (setq this-command 'vm-scroll-backward)
 297       (vm-scroll-backward arg)
 298       (save-excursion
 299         (set-buffer summary-buffer)
 300         (setq mail-win (get-buffer-window vm-mail-buffer)))
 301       (if (and mail-win
 302                mime::article/preview-buffer
 303                (get-buffer mime::article/preview-buffer))
 304           (progn
 305             (select-window mail-win)
 306             (goto-char (point-max))
 307             (switch-to-buffer mime::article/preview-buffer)
 308             (select-window summary-win)))
 309       )))
 310
 311 (set-alist 'mime-viewer/over-to-previous-method-alist
 312            'vm-mode
 313            (function
 314             (lambda ()
 315               (set-buffer mime::preview/article-buffer)
 316               (setq this-command 'vm-previous-message)
 317               (vm-previous-message 1 nil t)
 318               (tm-vm/view-message)
 319               )))
 320
 321 (set-alist 'mime-viewer/over-to-next-method-alist
 322            'vm-mode
 323            (function
 324             (lambda ()
 325               (set-buffer mime::preview/article-buffer)
 326               (setq this-command 'vm-next-message)
 327               (vm-next-message 1 nil t)
 328               (tm-vm/view-message)
 329               )))
 330
 331 ;; 1995/11/16 by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 332 (defun tm-vm/expunge-folder ()
 333   (interactive)
 334   (let* ((summary-buf (or (and (eq major-mode 'vm-summary-mode)
 335                                (current-buffer))
 336                           vm-summary-buffer))
 337          (preview-buf (save-excursion
 338                         (set-buffer (save-excursion
 339                                       (set-buffer summary-buf)
 340                                       vm-mail-buffer))
 341                         mime::article/preview-buffer))
 342          (preview-win (and preview-buf
 343                            (get-buffer-window preview-buf)))
 344          (win (selected-window)))
 345
 346     (vm-expunge-folder)
 347     (if preview-win
 348         (save-excursion
 349           (set-buffer summary-buf)
 350           (set-buffer vm-mail-buffer)
 351           (if (eq (point-min) (point-max))
 352               (kill-buffer preview-buf))))
 353     ))
 354
 355 ;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 356 ;;      1995/11/14 (cf. [tm-eng:162])
 357 (defun tm-vm/quit ()
 358   (interactive)
 359   (save-excursion
 360     (vm-select-folder-buffer)
 361     (if (and mime::article/preview-buffer
 362              (get-buffer mime::article/preview-buffer))
 363         (kill-buffer mime::article/preview-buffer)))
 364   (vm-quit)
 365   )
 366
 367 (substitute-key-definition 'vm-scroll-forward
 368                            'tm-vm/scroll-forward vm-mode-map)
 369 (substitute-key-definition 'vm-scroll-backward
 370                            'tm-vm/scroll-backward vm-mode-map)
 371 (substitute-key-definition 'vm-expunge-folder
 372                            'tm-vm/expunge-folder vm-mode-map)
 373 (substitute-key-definition 'vm-quit
 374                            'tm-vm/quit vm-mode-map)
 375 ;; end
 376
 377
 378 (defun tm-vm/toggle-preview-mode ()
 379   (interactive)
 380   (if tm-vm/automatic-mime-preview
 381       (progn
 382         (setq tm-vm/automatic-mime-preview nil)
 383         (vm-select-folder-buffer)
 384         (vm-display (current-buffer) t
 385                     '(tm-vm/toggle-preview-mode)
 386                     '(tm-vm/toggle-preview-mode reading-message))
 387         )
 388     (setq tm-vm/automatic-mime-preview t)
 389     (let ((win (selected-window)))
 390       (vm-select-folder-buffer)
 391       (save-window-excursion
 392         (let* ((mp (car vm-message-pointer))
 393                (ct  (vm-get-header-contents mp "Content-Type:"))
 394                (cte (vm-get-header-contents mp "Content-Transfer-Encoding:"))
 395                )
 396           (mime/viewer-mode nil (mime/parse-Content-Type (or ct "")) cte)
 397           ))
 398       (vm-display mime::article/preview-buffer t
 399                   '(tm-vm/toggle-preview-mode)
 400                   '(tm-vm/toggle-preview-mode reading-message))
 401       (select-window win)
 402       )
 403     ))
 404
 405
 406 ;;; @ for tm-view
 407 ;;;
 408
 409 (defun tm-vm/quit-view-message ()
 410   "Quit MIME-viewer and go back to VM.
 411 This function is called by `mime-viewer/quit' command via
 412 `mime-viewer/quitting-method-alist'."
 413   (mime-viewer/kill-buffer)
 414   (if (get-buffer mime/output-buffer-name)
 415       (bury-buffer mime/output-buffer-name))
 416   (vm-select-folder-buffer)
 417   (vm-display (current-buffer) t '(mime-viewer/quit mime-viewer/up-content)
 418               '(mime-viewer/quit reading-message)))
 419
 420 (defun tm-vm/view-message ()
 421   "Decode and view MIME encoded message, under VM."
 422   (interactive)
 423   (vm-follow-summary-cursor)
 424   (vm-select-folder-buffer)
 425   (vm-check-for-killed-summary)
 426   (vm-error-if-folder-empty)
 427   (vm-display (current-buffer) t '(tm-vm/view-message)
 428               '(tm-vm/view-mesage reading-message))
 429   (let* ((mp (car vm-message-pointer))
 430          (ct  (vm-get-header-contents mp "Content-Type:"))
 431          (cte (vm-get-header-contents mp "Content-Transfer-Encoding:"))
 432          (exposed (= (point-min) (vm-start-of mp))))
 433     (save-restriction
 434       (vm-widen-page)
 435       ;; vm-widen-page hides exposed header if pages are delimited.
 436       ;; So, here we expose it again.
 437       (if exposed
 438           (narrow-to-region (vm-start-of mp) (point-max)))
 439       (select-window (vm-get-buffer-window (current-buffer)))
 440       (mime/viewer-mode nil
 441                         (mime/parse-Content-Type (or ct ""))
 442                         cte)
 443       )))
 444
 445 (set-alist 'mime-viewer/quitting-method-alist
 446            'vm-mode
 447            'tm-vm/quit-view-message)
 448
 449 (set-alist 'mime-viewer/quitting-method-alist
 450            'vm-virtual-mode
 451            'tm-vm/quit-view-message)
 452
 453
 454 ;;; @ for tm-partial
 455 ;;;
 456
 457 (call-after-loaded
 458  'tm-partial
 459  (function
 460   (lambda ()
 461     (set-atype 'mime/content-decoding-condition
 462                '((type . "message/partial")
 463                  (method . mime-article/grab-message/partials)
 464                  (major-mode . vm-mode)
 465                  (summary-buffer-exp . vm-summary-buffer)
 466                  ))
 467     (set-alist 'tm-partial/preview-article-method-alist
 468                'vm-mode
 469                (function
 470                 (lambda ()
 471                   (tm-vm/view-message)
 472                   )))
 473     )))
 474
 475
 476 ;;; @ for tm-edit
 477 ;;;
 478
 479 ;;; @@ for multipart/digest
 480 ;;;
 481
 482 (defun tm-vm/enclose-messages (mlist)
 483   "Enclose the messages in MLIST as multipart/digest.
 484 The resulting digest is inserted at point in the current buffer.
 485
 486 MLIST should be a list of message structs (real or virtual).
 487 These are the messages that will be enclosed."
 488   (if mlist
 489       (let ((digest (consp (cdr mlist)))
 490             m)
 491         (save-restriction
 492           (narrow-to-region (point) (point))
 493           (while mlist
 494             (setq m (vm-real-message-of (car mlist)))
 495             (mime-editor/insert-tag "message" "rfc822")
 496             (tm-mail/insert-message m)
 497             (goto-char (point-max))
 498             (setq mlist (cdr mlist)))
 499           (if digest
 500               (mime-editor/enclose-digest-region (point-min) (point-max)))
 501           ))))
 502
 503 (defun tm-vm/forward-message ()
 504   "Forward the current message to one or more recipients.
 505 You will be placed in a Mail mode buffer as you would with a
 506 reply, but you must fill in the To: header and perhaps the
 507 Subject: header manually."
 508   (interactive)
 509   (if (not (equal vm-forwarding-digest-type "rfc1521"))
 510       (vm-forward-message)
 511     (vm-follow-summary-cursor)
 512     (vm-select-folder-buffer)
 513     (vm-check-for-killed-summary)
 514     (vm-error-if-folder-empty)
 515     (if (eq last-command 'vm-next-command-uses-marks)
 516         (let ((vm-digest-send-type vm-forwarding-digest-type))
 517           (setq this-command 'vm-next-command-uses-marks)
 518           (command-execute 'tm-vm/send-digest))
 519       (let ((dir default-directory)
 520             (mp vm-message-pointer))
 521         (save-restriction
 522           (widen)
 523           (vm-mail-internal
 524            (format "forward of %s's note re: %s"
 525                    (vm-su-full-name (car vm-message-pointer))
 526                    (vm-su-subject (car vm-message-pointer)))
 527            nil
 528            (and vm-forwarding-subject-format
 529                 (let ((vm-summary-uninteresting-senders nil))
 530                   (vm-sprintf 'vm-forwarding-subject-format (car mp)))))
 531           (make-local-variable 'vm-forward-list)
 532           (setq vm-system-state 'forwarding
 533                 vm-forward-list (list (car mp))
 534                 default-directory dir)
 535           (goto-char (point-min))
 536           (re-search-forward
 537            (concat "^" (regexp-quote mail-header-separator) "\n") nil 0)
 538           (tm-vm/enclose-messages vm-forward-list)
 539           (mail-position-on-field "To"))
 540         ;; (run-hooks 'tm-vm/forward-message-hook) ; Is it necessary?
 541         (run-hooks 'vm-mail-mode-hook)))))
 542
 543 (defun tm-vm/send-digest (&optional prefix)
 544   "Send a digest of all messages in the current folder to recipients.
 545 The type of the digest is specified by the variable vm-digest-send-type.
 546 You will be placed in a Mail mode buffer as is usual with replies, but you
 547 must fill in the To: and Subject: headers manually.
 548
 549 If invoked on marked messages (via vm-next-command-uses-marks),
 550 only marked messages will be put into the digest."
 551   (interactive "P")
 552   (if (not (equal vm-digest-send-type "rfc1521"))
 553       (vm-send-digest prefix)
 554     (vm-select-folder-buffer)
 555     (vm-check-for-killed-summary)
 556     (vm-error-if-folder-empty)
 557     (let ((dir default-directory)
 558           (mp vm-message-pointer)
 559           (mlist (if (eq last-command 'vm-next-command-uses-marks)
 560                      (vm-select-marked-or-prefixed-messages 0)
 561                    vm-message-list))
 562           start)
 563       (save-restriction
 564         (widen)
 565         (vm-mail-internal (format "digest from %s" (buffer-name)))
 566         (setq vm-system-state 'forwarding
 567               vm-forward-list mlist
 568               default-directory dir)
 569         (goto-char (point-min))
 570         (re-search-forward (concat "^" (regexp-quote mail-header-separator)
 571                                    "\n"))
 572         (goto-char (match-end 0))
 573         (setq start (point)
 574               mp mlist)
 575         (vm-unsaved-message "Building %s digest..." vm-digest-send-type)
 576         (tm-vm/enclose-messages mlist)
 577         (goto-char start)
 578         (setq mp mlist)
 579         (if prefix
 580           (progn
 581             (mime-editor/insert-tag "text" "plain")
 582             (vm-unsaved-message "Building digest preamble...")
 583             (while mp
 584               (let ((vm-summary-uninteresting-senders nil))
 585                 (insert (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n"))
 586               (if vm-digest-center-preamble
 587                   (progn
 588                     (forward-char -1)
 589                     (center-line)
 590                     (forward-char 1)))
 591               (setq mp (cdr mp)))))
 592         (mail-position-on-field "To")
 593         (message "Building %s digest... done" vm-digest-send-type)))
 594     ;; (run-hooks 'tm-vm/send-digest-hook) ; Is it necessary?
 595     (run-hooks 'vm-mail-mode-hook)))
 596
 597
 598 ;;; @@ setting
 599 ;;;
 600
 601 (substitute-key-definition 'vm-forward-message
 602                            'tm-vm/forward-message vm-mode-map)
 603 (substitute-key-definition 'vm-send-digest
 604                            'tm-vm/send-digest vm-mode-map)
 605
 606 (call-after-loaded
 607  'tm-edit
 608  (function
 609   (lambda ()
 610     (autoload 'tm-mail/insert-message "tm-mail")
 611     (set-alist 'mime-editor/message-inserter-alist
 612                'mail-mode (function tm-mail/insert-message))
 613     )))
 614
 615 (call-after-loaded
 616  'mime-setup
 617  (function
 618   (lambda ()
 619     ;;(remove-hook 'mail-mode-hook 'mime/editor-mode)
 620     ;;(add-hook 'vm-mail-mode-hook 'mime/editor-mode)
 621     (setq vm-forwarding-digest-type "rfc1521")
 622     (setq vm-digest-send-type "rfc1521")
 623     )))
 624
 625
 626 ;;; @ for BBDB
 627 ;;;
 628
 629 (call-after-loaded
 630  'bbdb-vm
 631  (function
 632   (lambda ()
 633     (or (fboundp 'tm:bbdb/vm-update-record)
 634         (fset 'tm:bbdb/vm-update-record
 635               (symbol-function 'bbdb/vm-update-record))
 636         )
 637     (defun bbdb/vm-update-record (&optional offer-to-create)
 638       (vm-select-folder-buffer)
 639       (let ((vm-mail-buffer
 640              (if (and mime::article/preview-buffer
 641                       (get-buffer mime::article/preview-buffer))
 642                  mime::article/preview-buffer
 643                (current-buffer)
 644                ))
 645             (bbdb/vm-update-record-recursive
 646              (boundp 'bbdb/vm-update-record-recursive))
 647             bbdb/vm-update-record-recursive ret)
 648         (let ((bbdb/vm-update-record-answer
 649                (if (boundp 'bbdb/vm-update-record-answer)
 650                    (setq bbdb/vm-update-record-answer
 651                          (or bbdb/vm-update-record-answer
 652                              (tm:bbdb/vm-update-record)
 653                              ))
 654                  (setq ret (tm:bbdb/vm-update-record))
 655                  nil)))
 656           (or bbdb/vm-update-record-answer ret)
 657           )))
 658     (defun tm-vm/bbdb-update-record (&optional offer-to-create)
 659       (let ((vm-mail-buffer (current-buffer)))
 660         (tm:bbdb/vm-update-record offer-to-create)
 661         ))
 662     (remove-hook 'vm-select-message-hook 'bbdb/vm-update-record)
 663     (remove-hook 'vm-show-message-hook 'bbdb/vm-update-record)
 664     (add-hook 'tm-vm/select-message-hook 'tm-vm/update-record)
 665     )))
 666
 667
 668 ;;; @ end
 669 ;;;
 670
 671 (provide 'tm-vm)