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.36 $
  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.36 1995/12/15 13:58:51 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
  50 ;;; @ for MIME encoded-words
  51 ;;;
  52
  53 (defvar tm-vm/use-tm-patch nil
  54   "Does not decode encoded-words in summary buffer if it is t.
  55 If you use tiny-mime patch for VM (by RIKITAKE Kenji
  56 <kenji@reseau.toyonaka.osaka.jp>), please set it t [tm-vm.el]")
  57
  58 (or tm-vm/use-tm-patch
  59     (progn
  60 ;;;
  61 (defvar tm-vm/chop-full-name-function 'tm-vm/default-chop-full-name)
  62 (setq vm-chop-full-name-function tm-vm/chop-full-name-function)
  63
  64 (defun tm-vm/default-chop-full-name (address)
  65   (let* ((ret (vm-default-chop-full-name address))
  66          (full-name (car ret))
  67          )
  68     (if (stringp full-name)
  69         (cons (mime-eword/decode-string full-name)
  70               (cdr ret))
  71       ret)))
  72
  73 (require 'vm-summary)
  74 (or (fboundp 'tm:vm-su-subject)
  75     (fset 'tm:vm-su-subject (symbol-function 'vm-su-subject))
  76     )
  77 (defun vm-su-subject (m)
  78   (mime-eword/decode-string (tm:vm-su-subject m))
  79   )
  80 ;;;
  81 ))
  82
  83 (defun tm-vm/decode-message-header (&optional count)
  84   "Decode MIME header of current message through tiny-mime.
  85 Numeric prefix argument COUNT means to decode the current message plus
  86 the next COUNT-1 messages.  A negative COUNT means decode the current
  87 message and the previous COUNT-1 messages.
  88 When invoked on marked messages (via vm-next-command-uses-marks),
  89 all marked messages are affected, other messages are ignored."
  90   (interactive "p")
  91   (or count (setq count 1))
  92   (vm-follow-summary-cursor)
  93   (vm-select-folder-buffer)
  94   (vm-check-for-killed-summary)
  95   (vm-error-if-folder-empty)
  96   (vm-error-if-folder-read-only)
  97   (let ((mlist (vm-select-marked-or-prefixed-messages count))
  98         (realm nil)
  99         (vlist nil)
 100         (vbufs nil))
 101     (save-excursion
 102       (while mlist
 103         (setq realm (vm-real-message-of (car mlist)))
 104         ;; Go to real folder of this message.
 105         ;; But maybe this message is already real message...
 106         (set-buffer (vm-buffer-of realm))
 107         (let ((buffer-read-only nil))
 108           (vm-save-restriction
 109            (narrow-to-region (vm-headers-of realm) (vm-text-of realm))
 110            (mime/decode-message-header))
 111           (let ((vm-message-pointer (list realm))
 112                 (last-command nil))
 113             (vm-discard-cached-data))
 114           ;; Mark each virtual and real message for later summary
 115           ;; update.
 116           (setq vlist (cons realm (vm-virtual-messages-of realm)))
 117           (while vlist
 118             (vm-mark-for-summary-update (car vlist))
 119             ;; Remember virtual and real folders related this message,
 120             ;; for later display update.
 121             (or (memq (vm-buffer-of (car vlist)) vbufs)
 122                 (setq vbufs (cons (vm-buffer-of (car vlist)) vbufs)))
 123             (setq vlist (cdr vlist)))
 124           (if (eq vm-flush-interval t)
 125               (vm-stuff-virtual-attributes realm)
 126             (vm-set-modflag-of realm t)))
 127         (setq mlist (cdr mlist)))
 128       ;; Update mail-buffers and summaries.
 129       (while vbufs
 130         (set-buffer (car vbufs))
 131         (vm-preview-current-message)
 132         (setq vbufs (cdr vbufs))))))
 133
 134
 135 ;;; @ automatic MIME preview
 136 ;;;
 137
 138 (defvar tm-vm/automatic-mime-preview t
 139   "*If non-nil, show MIME processed article.")
 140
 141 (defun tm-vm/preview-current-message ()
 142   ;;; suggested by Simon Rowe <smr@robots.oxford.ac.uk>
 143   ;;;   (cf. [tm-eng:163])
 144   ;; Selecting a new mail message, but we're already displaying a mime
 145   ;; on in the window, make sure that the mail buffer is displayed.
 146   (if (get-buffer-window mime/output-buffer-name)
 147       (delete-window (get-buffer-window (get-buffer mime/output-buffer-name)))
 148     )
 149   ;; fixed by Shuhei KOBAYASHI <shuhei@cmpt01.phys.tohoku.ac.jp>
 150   ;;    1995/12/4 (cf. [tm-ja:1190])
 151   (if (and vm-message-pointer tm-vm/automatic-mime-preview
 152            ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 153            ;;   1995/11/17 (cf. [tm-ja:1120])
 154            (display-buffer (current-buffer))
 155            (let* ((mp (car vm-message-pointer))
 156                   (ct  (vm-get-header-contents mp "Content-Type:"))
 157                   (cte (vm-get-header-contents
 158                         mp "Content-Transfer-Encoding:"))
 159                   )
 160              ;; Check if this message actually is a mime, or just a text
 161              ;; one sent by someone using PINE or similar.
 162              (and ct
 163                   (not (and (string= (car (mime/parse-Content-Type ct))
 164                                      "text/plain")
 165                             (member cte '("7bit" "8bit" "binary"))
 166                             ))))
 167            )
 168       (let ((win (selected-window)) buf)
 169         (setq buf (window-buffer win))
 170         (let ((pwin (and mime::article/preview-buffer
 171                          (get-buffer mime::article/preview-buffer)
 172                          (get-buffer-window mime::article/preview-buffer))))
 173           (if (and pwin
 174                    (not (eq win pwin)))
 175               (delete-window pwin)
 176             ))
 177         (vm-display nil nil
 178                     '(vm-next-message
 179                       vm-previous-message
 180                       vm-delete-message
 181                       vm-undelete-message
 182                       vm-scroll-forward vm-scroll-backward)
 183                     (list this-command 'reading-message))
 184         (setq win (get-buffer-window buf))
 185         (if win
 186             (select-window win)
 187           )
 188         (save-window-excursion
 189           (vm-select-folder-buffer)
 190           (setq win (get-buffer-window (current-buffer)))
 191           ;; (vm-display (current-buffer) t
 192           ;;             '(vm-scroll-forward vm-scroll-backward)
 193           ;;             (list this-command 'reading-message))
 194           ;; (select-window (get-buffer-window (current-buffer)))
 195           (mime/viewer-mode)
 196           (setq buf (current-buffer))
 197           (run-hooks 'tm-vm/select-message-hook)
 198           )
 199         (set-window-buffer win buf)
 200         ;;(select-window win)
 201         )
 202     ;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 203     ;;  1995/11/17
 204     (if (and mime::article/preview-buffer
 205              (get-buffer mime::article/preview-buffer))
 206         (kill-buffer mime::article/preview-buffer))
 207     (if tm-vm/automatic-mime-preview
 208         (let (buffer-read-only)
 209           (mime/decode-message-header)
 210           (run-hooks 'tm-vm/select-message-hook)
 211           ))
 212     ))
 213
 214 (add-hook 'vm-select-message-hook 'tm-vm/preview-current-message)
 215
 216 (defun tm-vm/visit-folder-function ()
 217   (tm-vm/preview-current-message)
 218   (and vm-mail-buffer (set-buffer vm-mail-buffer))
 219   )
 220
 221 (add-hook 'vm-visit-folder-hook 'tm-vm/visit-folder-function)
 222
 223 ;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 224 ;;      1995/11/14 (cf.[tm-eng:162])
 225 (defun tm-vm/scroll-forward (&optional arg)
 226   (interactive "P")
 227   (if (not tm-vm/automatic-mime-preview)
 228       ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 229       ;;        1995/11/17 (cf.[tm-ja:1119])
 230       (progn
 231         (setq this-command 'vm-scroll-forward)
 232         (vm-scroll-forward arg))
 233     (let* ((summary-buffer (or vm-summary-buffer
 234                                (and (eq major-mode 'vm-summary-mode)
 235                                     (current-buffer))))
 236            (summary-win (get-buffer-window summary-buffer))
 237            (mail-buffer (save-excursion
 238                           (set-buffer summary-buffer)
 239                           vm-mail-buffer))
 240            (mail-win (get-buffer-window mail-buffer))
 241            (preview-buf (save-excursion
 242                           (set-buffer mail-buffer)
 243                           mime::article/preview-buffer))
 244            (preview-win (and preview-buf (get-buffer-window preview-buf)))
 245            )
 246       (if preview-win
 247           (progn
 248             (select-window preview-win)
 249             (if (pos-visible-in-window-p (point-max) preview-win)
 250                 (progn
 251                   (switch-to-buffer mail-buffer)
 252                   (goto-char (point-max))
 253                   (select-window summary-win))
 254               (scroll-up)
 255               (switch-to-buffer mail-buffer)
 256               (select-window summary-win))))
 257       ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 258       ;;        1995/11/17 (cf.[tm-ja:1119])
 259       (setq this-command 'vm-scroll-forward)
 260       (let ((vm-inhibit-startup-message t))
 261         (vm-scroll-forward arg))
 262       (save-excursion
 263         (set-buffer summary-buffer)
 264         (setq mail-win (get-buffer-window vm-mail-buffer)))
 265       ;; fixed by Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 266       ;;        1995/11/17
 267       (if (and mail-win
 268                mime::article/preview-buffer
 269                (get-buffer mime::article/preview-buffer))
 270           (progn
 271             (select-window mail-win)
 272             (switch-to-buffer mime::article/preview-buffer)
 273             (select-window summary-win)))
 274       )))
 275
 276 (defun tm-vm/scroll-backward (&optional arg)
 277   (interactive "P")
 278   (if (not tm-vm/automatic-mime-preview)
 279       ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 280       ;;        1995/11/17 (cf.[tm-ja:1119])
 281       (progn
 282         (setq this-command 'vm-scroll-backward)
 283         (vm-scroll-backward arg))
 284     (let* ((summary-buffer (or vm-summary-buffer
 285                                (and (eq major-mode 'vm-summary-mode)
 286                                     (current-buffer))))
 287            (summary-win (get-buffer-window summary-buffer))
 288            (mail-buffer (save-excursion
 289                           (set-buffer summary-buffer)
 290                           vm-mail-buffer))
 291            (mail-win (get-buffer-window mail-buffer))
 292            (preview-buf (save-excursion
 293                           (set-buffer mail-buffer)
 294                           mime::article/preview-buffer))
 295            (preview-win (and preview-buf (get-buffer-window preview-buf)))
 296            )
 297       (if preview-win
 298           (progn
 299             (select-window preview-win)
 300             (if (pos-visible-in-window-p (point-min) preview-win)
 301                 (progn
 302                   (switch-to-buffer mail-buffer)
 303                   (goto-char (point-min))
 304                   (select-window summary-win))
 305               (scroll-down)
 306               (switch-to-buffer mail-buffer)
 307               (select-window summary-win))))
 308       ;; fixed by SHIONO Jun'ichi <jun@case.nm.fujitsu.co.jp>
 309       ;;        1995/11/17 (cf.[tm-ja:1119])
 310       (setq this-command 'vm-scroll-backward)
 311       (let ((vm-inhibit-startup-message t))
 312         (vm-scroll-backward arg))
 313       (save-excursion
 314         (set-buffer summary-buffer)
 315         (setq mail-win (get-buffer-window vm-mail-buffer)))
 316       (if (and mail-win
 317                mime::article/preview-buffer
 318                (get-buffer mime::article/preview-buffer))
 319           (progn
 320             (select-window mail-win)
 321 ;           (goto-char (point-max))
 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 (defun tm-vm/enclose-messages (mlist)
 520   "Enclose the messages in MLIST as multipart/digest.
 521 The resulting digest is inserted at point in the current buffer.
 522
 523 MLIST should be a list of message structs (real or virtual).
 524 These are the messages that will be enclosed."
 525   (if mlist
 526       (let ((digest (consp (cdr mlist)))
 527             m)
 528         (save-restriction
 529           (narrow-to-region (point) (point))
 530           (while mlist
 531             (setq m (vm-real-message-of (car mlist)))
 532             (mime-editor/insert-tag "message" "rfc822")
 533             (tm-mail/insert-message m)
 534             (goto-char (point-max))
 535             (setq mlist (cdr mlist)))
 536           (if digest
 537               (mime-editor/enclose-digest-region (point-min) (point-max)))
 538           ))))
 539
 540 (defun tm-vm/forward-message ()
 541   "Forward the current message to one or more recipients.
 542 You will be placed in a Mail mode buffer as you would with a
 543 reply, but you must fill in the To: header and perhaps the
 544 Subject: header manually."
 545   (interactive)
 546   (if (not (equal vm-forwarding-digest-type "rfc1521"))
 547       (vm-forward-message)
 548     (vm-follow-summary-cursor)
 549     (vm-select-folder-buffer)
 550     (vm-check-for-killed-summary)
 551     (vm-error-if-folder-empty)
 552     (if (eq last-command 'vm-next-command-uses-marks)
 553         (let ((vm-digest-send-type vm-forwarding-digest-type))
 554           (setq this-command 'vm-next-command-uses-marks)
 555           (command-execute 'tm-vm/send-digest))
 556       (let ((dir default-directory)
 557             (mp vm-message-pointer))
 558         (save-restriction
 559           (widen)
 560           (vm-mail-internal
 561            (format "forward of %s's note re: %s"
 562                    (vm-su-full-name (car vm-message-pointer))
 563                    (vm-su-subject (car vm-message-pointer)))
 564            nil
 565            (and vm-forwarding-subject-format
 566                 (let ((vm-summary-uninteresting-senders nil))
 567                   (vm-sprintf 'vm-forwarding-subject-format (car mp)))))
 568           (make-local-variable 'vm-forward-list)
 569           (setq vm-system-state 'forwarding
 570                 vm-forward-list (list (car mp))
 571                 default-directory dir)
 572           (goto-char (point-min))
 573           (re-search-forward
 574            (concat "^" (regexp-quote mail-header-separator) "\n") nil 0)
 575           (tm-vm/enclose-messages vm-forward-list)
 576           (mail-position-on-field "To"))
 577         (run-hooks 'tm-vm/forward-message-hook)
 578         (run-hooks 'vm-mail-mode-hook)))))
 579
 580 (defun tm-vm/send-digest (&optional prefix)
 581   "Send a digest of all messages in the current folder to recipients.
 582 The type of the digest is specified by the variable vm-digest-send-type.
 583 You will be placed in a Mail mode buffer as is usual with replies, but you
 584 must fill in the To: and Subject: headers manually.
 585
 586 If invoked on marked messages (via vm-next-command-uses-marks),
 587 only marked messages will be put into the digest."
 588   (interactive "P")
 589   (if (not (equal vm-digest-send-type "rfc1521"))
 590       (vm-send-digest prefix)
 591     (vm-select-folder-buffer)
 592     (vm-check-for-killed-summary)
 593     (vm-error-if-folder-empty)
 594     (let ((dir default-directory)
 595           (mp vm-message-pointer)
 596           (mlist (if (eq last-command 'vm-next-command-uses-marks)
 597                      (vm-select-marked-or-prefixed-messages 0)
 598                    vm-message-list))
 599           start)
 600       (save-restriction
 601         (widen)
 602         (vm-mail-internal (format "digest from %s" (buffer-name)))
 603         (setq vm-system-state 'forwarding
 604               vm-forward-list mlist
 605               default-directory dir)
 606         (goto-char (point-min))
 607         (re-search-forward (concat "^" (regexp-quote mail-header-separator)
 608                                    "\n"))
 609         (goto-char (match-end 0))
 610         (setq start (point)
 611               mp mlist)
 612         (vm-unsaved-message "Building %s digest..." vm-digest-send-type)
 613         (tm-vm/enclose-messages mlist)
 614         (goto-char start)
 615         (setq mp mlist)
 616         (if prefix
 617           (progn
 618             (mime-editor/insert-tag "text" "plain")
 619             (vm-unsaved-message "Building digest preamble...")
 620             (while mp
 621               (let ((vm-summary-uninteresting-senders nil))
 622                 (insert (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n"))
 623               (if vm-digest-center-preamble
 624                   (progn
 625                     (forward-char -1)
 626                     (center-line)
 627                     (forward-char 1)))
 628               (setq mp (cdr mp)))))
 629         (mail-position-on-field "To")
 630         (message "Building %s digest... done" vm-digest-send-type)))
 631     (run-hooks 'tm-vm/send-digest-hook)
 632     (run-hooks 'vm-mail-mode-hook)))
 633
 634
 635 ;;; @@ setting
 636 ;;;
 637
 638 (substitute-key-definition 'vm-forward-message
 639                            'tm-vm/forward-message vm-mode-map)
 640 (substitute-key-definition 'vm-send-digest
 641                            'tm-vm/send-digest vm-mode-map)
 642
 643 (defvar tm-vm/use-xemacs-popup-menu t)
 644
 645 ;;; modified by Steven L. Baur <steve@miranova.com>
 646 ;;;     1995/12/6 (c.f. [tm-en:209])
 647 (defun mime-editor/attach-to-vm-mode-menu ()
 648   "Arrange to attach MIME editor's popup menu to VM's"
 649   (if (boundp 'vm-menu-mail-menu)
 650       (progn
 651         (setq vm-menu-mail-menu
 652               (append vm-menu-mail-menu
 653                       (list "----"
 654                             mime-editor/popup-menu-for-xemacs)))
 655         (remove-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu)
 656         )))
 657
 658 (call-after-loaded
 659  'tm-edit
 660  (function
 661   (lambda ()
 662     (autoload 'tm-mail/insert-message "tm-mail")
 663     (set-alist 'mime-editor/message-inserter-alist
 664                'mail-mode (function tm-mail/insert-message))
 665     (if (and (string-match "XEmacs\\|Lucid" emacs-version)
 666              tm-vm/use-xemacs-popup-menu)
 667         (add-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu)
 668       )
 669     )))
 670
 671 (call-after-loaded
 672  'mime-setup
 673  (function
 674   (lambda ()
 675     (setq vm-forwarding-digest-type "rfc1521")
 676     (setq vm-digest-send-type "rfc1521")
 677     )))
 678
 679
 680 ;;; @ for BBDB
 681 ;;;
 682
 683 (call-after-loaded
 684  'bbdb-vm
 685  (function
 686   (lambda ()
 687     (or (fboundp 'tm:bbdb/vm-update-record)
 688         (fset 'tm:bbdb/vm-update-record
 689               (symbol-function 'bbdb/vm-update-record))
 690         )
 691     (defun bbdb/vm-update-record (&optional offer-to-create)
 692       (vm-select-folder-buffer)
 693       (let ((vm-mail-buffer
 694              (if (and mime::article/preview-buffer
 695                       (get-buffer mime::article/preview-buffer))
 696                  mime::article/preview-buffer
 697                (current-buffer)
 698                ))
 699             (bbdb/vm-update-record-recursive
 700              (boundp 'bbdb/vm-update-record-recursive))
 701             bbdb/vm-update-record-recursive ret)
 702         (let ((bbdb/vm-update-record-answer
 703                (if (boundp 'bbdb/vm-update-record-answer)
 704                    (setq bbdb/vm-update-record-answer
 705                          (or bbdb/vm-update-record-answer
 706                              (tm:bbdb/vm-update-record)
 707                              ))
 708                  (setq ret (tm:bbdb/vm-update-record))
 709                  nil)))
 710           (or bbdb/vm-update-record-answer ret)
 711           )))
 712     (defun tm-vm/bbdb-update-record (&optional offer-to-create)
 713       (let ((vm-mail-buffer (current-buffer)))
 714         (tm:bbdb/vm-update-record offer-to-create)
 715         ))
 716     (remove-hook 'vm-select-message-hook 'bbdb/vm-update-record)
 717     (remove-hook 'vm-show-message-hook 'bbdb/vm-update-record)
 718     (add-hook 'tm-vm/select-message-hook 'tm-vm/bbdb-update-record)
 719     )))
 720
 721
 722 ;;; @ end
 723 ;;;
 724
 725 (provide 'tm-vm)