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