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