tm-vm.el

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