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