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.42 $
  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.42 1996/02/09 00:31:21 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               (narrow-to-region (point)
 225                                 (search-forward "\n\n" nil t))
 226               ))
 227         ;; don't do MIME processing. decode header only.
 228         (let (buffer-read-only)
 229           (mime/decode-message-header))
 230         )
 231     ;; don't preview; do nothing.
 232     )
 233   (tm-vm/display-preview-buffer)
 234   (run-hooks 'tm-vm/select-message-hook))
 235
 236 (defun tm-vm/show-current-message ()
 237   (if mime::preview/article-buffer
 238       (set-buffer mime::preview/article-buffer)
 239     (vm-select-folder-buffer))
 240   ;; Now current buffer is folder buffer.
 241   (if (or t ; mime/viewer-mode doesn't support narrowing yet.
 242           (null vm-preview-lines)
 243           (and (not vm-preview-read-messages)
 244                (not (vm-new-flag
 245                      (car vm-message-pointer)))
 246                (not (vm-unread-flag
 247                      (car vm-message-pointer)))))
 248       (save-excursion
 249         (set-buffer mime::article/preview-buffer)
 250         (save-excursion
 251           (save-excursion
 252             (goto-char (point-min))
 253             (widen))
 254           ;; narrow to page; mime/viewer-mode doesn't support narrowing yet.
 255           )))
 256   (if (vm-get-visible-buffer-window mime::article/preview-buffer)
 257       (progn
 258         (setq tm-vm/system-state 'reading)
 259         (if (vm-new-flag (car vm-message-pointer))
 260             (vm-set-new-flag (car vm-message-pointer) nil))
 261         (if (vm-unread-flag (car vm-message-pointer))
 262             (vm-set-unread-flag (car vm-message-pointer) nil))
 263         (vm-update-summary-and-mode-line)
 264         (tm-vm/howl-if-eom))
 265     (vm-update-summary-and-mode-line)))
 266
 267 (defun tm-vm/toggle-preview-mode ()
 268   (interactive)
 269   (vm-select-folder-buffer)
 270   (vm-display (current-buffer) t (list this-command)
 271               (list this-command 'reading-message))
 272   (if tm-vm/automatic-mime-preview
 273       (setq tm-vm/automatic-mime-preview nil
 274             tm-vm/system-state nil)
 275     (setq tm-vm/automatic-mime-preview t
 276           tm-vm/system-state nil)
 277     (save-restriction
 278        (vm-widen-page)
 279        (let* ((mp (car vm-message-pointer))
 280               (exposed (= (point-min) (vm-start-of mp))))
 281          (if (or (not tm-vm/strict-mime)
 282                  (vm-get-header-contents mp "MIME-Version:"))
 283              ;; do MIME processiong.
 284              (progn
 285                (set (make-local-variable 'tm-vm/system-state) 'previewing)
 286                (save-window-excursion
 287                  (mime/viewer-mode)
 288                  (goto-char (point-min))
 289                  (narrow-to-region (point)
 290                                    (search-forward "\n\n" nil t))
 291                  ))
 292            ;; don't do MIME processing. decode header only.
 293            (let (buffer-read-only)
 294              (mime/decode-message-header))
 295            )
 296          ;; don't preview; do nothing.
 297          ))
 298     (tm-vm/display-preview-buffer)
 299     ))
 300
 301 (add-hook 'vm-select-message-hook 'tm-vm/preview-current-message)
 302 (add-hook 'vm-visit-folder-hook   'tm-vm/preview-current-message)
 303 \f
 304 ;;; tm-vm move commands
 305 ;;;
 306
 307 (defmacro tm-vm/save-window-excursion (&rest forms)
 308   (list 'let '((tm-vm/selected-window (selected-window)))
 309         (list 'unwind-protect
 310               (cons 'progn forms)
 311               '(if (window-live-p tm-vm/selected-window)
 312                    (select-window tm-vm/selected-window)))))
 313
 314 ;;; based on vm-scroll-forward [vm-page.el]
 315 (defun tm-vm/scroll-forward (&optional arg)
 316   (interactive "P")
 317   (let ((this-command 'vm-scroll-forward))
 318     (if (not (tm-vm/system-state))
 319         (vm-scroll-forward arg)
 320       (let* ((mp-changed (vm-follow-summary-cursor))
 321              (mbuf (or (vm-select-folder-buffer) (current-buffer)))
 322              (mwin (vm-get-buffer-window mbuf))
 323              (pbuf (and mime::article/preview-buffer
 324                         (get-buffer mime::article/preview-buffer)))
 325              (pwin (and pbuf (vm-get-buffer-window pbuf)))
 326              (was-invisible (and (null mwin) (null pwin)))
 327              )
 328         ;; now current buffer is folder buffer.
 329         (tm-vm/save-window-excursion
 330          (if (or mp-changed was-invisible)
 331              (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
 332                          (list this-command 'reading-message)))
 333          (tm-vm/display-preview-buffer)
 334          (setq mwin (vm-get-buffer-window mbuf)
 335                pwin (and pbuf (vm-get-buffer-window pbuf)))
 336          (cond
 337           (was-invisible
 338            nil
 339            )
 340           ((null pbuf)
 341            ;; preview buffer is killed.
 342            (tm-vm/preview-current-message)
 343            (vm-update-summary-and-mode-line))
 344           ((eq (tm-vm/system-state) 'previewing)
 345            (tm-vm/show-current-message))
 346           (t
 347            (select-window pwin)
 348            (set-buffer pbuf)
 349            (if (pos-visible-in-window-p (point-max) pwin)
 350                (tm-vm/next-message)
 351              ;; not end of message. scroll preview buffer only.
 352              (scroll-up)
 353              (tm-vm/howl-if-eom)
 354              (set-buffer mbuf))
 355            ))))
 356       )))
 357
 358 ;;; based on vm-scroll-backward [vm-page.el]
 359 (defun tm-vm/scroll-backward (&optional arg)
 360   (interactive "P")
 361   (let ((this-command 'vm-scroll-backward))
 362     (if (not (tm-vm/system-state))
 363         (vm-scroll-backward arg)
 364       (let* ((mp-changed (vm-follow-summary-cursor))
 365              (mbuf (or (vm-select-folder-buffer) (current-buffer)))
 366              (mwin (vm-get-buffer-window mbuf))
 367              (pbuf (and mime::article/preview-buffer
 368                         (get-buffer mime::article/preview-buffer)))
 369              (pwin (and pbuf (vm-get-buffer-window pbuf)))
 370              (was-invisible (and (null mwin) (null pwin)))
 371              )
 372         ;; now current buffer is folder buffer.
 373         (if (or mp-changed was-invisible)
 374             (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
 375                         (list this-command 'reading-message)))
 376         (tm-vm/save-window-excursion
 377          (tm-vm/display-preview-buffer)
 378          (setq mwin (vm-get-buffer-window mbuf)
 379                pwin (and pbuf (vm-get-buffer-window pbuf)))
 380          (cond
 381           (was-invisible
 382            nil
 383            )
 384           ((null pbuf)
 385            ;; preview buffer is killed.
 386            (tm-vm/preview-current-message)
 387            (vm-update-summary-and-mode-line))
 388           ((eq (tm-vm/system-state) 'previewing)
 389            (tm-vm/show-current-message))
 390           (t
 391            (select-window pwin)
 392            (set-buffer pbuf)
 393            (if (pos-visible-in-window-p (point-min) pwin)
 394                nil
 395              ;; scroll preview buffer only.
 396              (scroll-down)
 397              (set-buffer mbuf))
 398            ))))
 399       )))
 400
 401 ;;; based on vm-beginning-of-message [vm-page.el]
 402 (defun tm-vm/beginning-of-message ()
 403   "Moves to the beginning of the current message."
 404   (interactive)
 405   (if (not (tm-vm/system-state))
 406       (progn
 407         (setq this-command 'vm-beginning-of-message)
 408         (vm-beginning-of-message))
 409     (vm-follow-summary-cursor)
 410     (vm-select-folder-buffer)
 411     (vm-check-for-killed-summary)
 412     (vm-error-if-folder-empty)
 413     (let ((mbuf (current-buffer))
 414           (pbuf (and mime::article/preview-buffer
 415                      (get-buffer mime::article/preview-buffer))))
 416       (if (null pbuf)
 417           (progn
 418             (tm-vm/preview-current-message)
 419             (setq pbuf (get-buffer mime::article/preview-buffer))
 420             ))
 421       (vm-display mbuf t '(vm-beginning-of-message)
 422                   '(vm-beginning-of-message reading-message))
 423       (tm-vm/display-preview-buffer)
 424       (set-buffer pbuf)
 425       (tm-vm/save-window-excursion
 426        (select-window (vm-get-buffer-window pbuf))
 427        (push-mark)
 428        (goto-char (point-min))
 429        ))))
 430
 431 ;;; based on vm-end-of-message [vm-page.el]
 432 (defun tm-vm/end-of-message ()
 433   "Moves to the end of the current message."
 434   (interactive)
 435   (if (not (tm-vm/system-state))
 436       (progn
 437         (setq this-command 'vm-end-of-message)
 438         (vm-end-of-message))
 439     (vm-follow-summary-cursor)
 440     (vm-select-folder-buffer)
 441     (vm-check-for-killed-summary)
 442     (vm-error-if-folder-empty)
 443     (let ((mbuf (current-buffer))
 444           (pbuf (and mime::article/preview-buffer
 445                      (get-buffer mime::article/preview-buffer))))
 446       (if (null pbuf)
 447           (progn
 448             (tm-vm/preview-current-message)
 449             (setq pbuf (get-buffer mime::article/preview-buffer))
 450             ))
 451       (vm-display mbuf t '(vm-end-of-message)
 452                   '(vm-end-of-message reading-message))
 453       (tm-vm/display-preview-buffer)
 454       (set-buffer pbuf)
 455       (tm-vm/save-window-excursion
 456        (select-window (vm-get-buffer-window pbuf))
 457        (push-mark)
 458        (goto-char (point-max))
 459        ))))
 460
 461 ;;; based on vm-howl-if-eom [vm-page.el]
 462 (defun tm-vm/howl-if-eom ()
 463   (let* ((pbuf (or mime::article/preview-buffer (current-buffer)))
 464          (pwin (and (vm-get-visible-buffer-window pbuf))))
 465     (and pwin
 466          (save-excursion
 467            (save-window-excursion
 468              (condition-case ()
 469                  (let ((next-screen-context-lines 0))
 470                    (select-window pwin)
 471                    (save-excursion
 472                      (save-window-excursion
 473                        (let ((scroll-in-place-replace-original nil))
 474                          (scroll-up))))
 475                    nil)
 476                (error t))))
 477          (tm-vm/emit-eom-blurb)
 478          )))
 479
 480 ;;; based on vm-emit-eom-blurb [vm-page.el]
 481 (defun tm-vm/emit-eom-blurb ()
 482   (save-excursion
 483     (if mime::preview/article-buffer
 484         (set-buffer mime::preview/article-buffer))
 485     (vm-emit-eom-blurb)))
 486
 487 ;;; based on vm-quit [vm-folder.el]
 488 (defun tm-vm/quit ()
 489   (interactive)
 490   (save-excursion
 491     (vm-select-folder-buffer)
 492     (if (and mime::article/preview-buffer
 493              (get-buffer mime::article/preview-buffer))
 494         (kill-buffer mime::article/preview-buffer)))
 495   (vm-quit))
 496
 497 (substitute-key-definition 'vm-scroll-forward
 498                            'tm-vm/scroll-forward vm-mode-map)
 499 (substitute-key-definition 'vm-scroll-backward
 500                            'tm-vm/scroll-backward vm-mode-map)
 501 (substitute-key-definition 'vm-beginning-of-message
 502                            'tm-vm/beginning-of-message vm-mode-map)
 503 (substitute-key-definition 'vm-end-of-message
 504                            'tm-vm/end-of-message vm-mode-map)
 505 (substitute-key-definition 'vm-quit
 506                            'tm-vm/quit vm-mode-map)
 507
 508 ;;; based on vm-next-message [vm-motion.el]
 509 (defun tm-vm/next-message ()
 510   (set-buffer mime::preview/article-buffer)
 511   (let ((this-command 'vm-next-message)
 512         (owin (selected-window))
 513         (vm-preview-lines nil)
 514         )
 515     (vm-next-message 1 nil t)
 516     (if (window-live-p owin)
 517         (select-window owin))))
 518
 519 ;;; based on vm-previous-message [vm-motion.el]
 520 (defun tm-vm/previous-message ()
 521   (set-buffer mime::preview/article-buffer)
 522   (let ((this-command 'vm-previous-message)
 523         (owin (selected-window))
 524         (vm-preview-lines nil)
 525         )
 526     (vm-previous-message 1 nil t)
 527     (if (window-live-p owin)
 528         (select-window owin))))
 529
 530 (set-alist 'mime-viewer/over-to-previous-method-alist
 531            'vm-mode 'tm-vm/previous-message)
 532 (set-alist 'mime-viewer/over-to-next-method-alist
 533            'vm-mode 'tm-vm/next-message)
 534 (set-alist 'mime-viewer/over-to-previous-method-alist
 535            'vm-virtual-mode 'tm-vm/previous-message)
 536 (set-alist 'mime-viewer/over-to-next-method-alist
 537            'vm-virtual-mode 'tm-vm/next-message)
 538
 539 \f
 540 ;;; @ for tm-view
 541 ;;;
 542
 543 (defun tm-vm/quit-view-message ()
 544   "Quit MIME-viewer and go back to VM.
 545 This function is called by `mime-viewer/quit' command via
 546 `mime-viewer/quitting-method-alist'."
 547   (if (get-buffer mime/output-buffer-name)
 548       (vm-undisplay-buffer mime/output-buffer-name))
 549   (if (and tm-vm/automatic-mime-preview
 550            (save-excursion
 551              (set-buffer mime::preview/article-buffer)
 552              vm-summary-buffer))
 553       (switch-to-buffer mime::preview/article-buffer)
 554     (mime-viewer/kill-buffer)
 555     (vm-select-folder-buffer)
 556     (setq tm-vm/system-state nil))
 557   (vm-display (current-buffer) t (list this-command)
 558               (list this-command 'reading-message))
 559   (tm-vm/display-preview-buffer)
 560   )
 561
 562 (defun tm-vm/view-message ()
 563   "Decode and view MIME encoded message, under VM."
 564   (interactive)
 565   (vm-follow-summary-cursor)
 566   (vm-select-folder-buffer)
 567   (vm-check-for-killed-summary)
 568   (vm-error-if-folder-empty)
 569   (vm-display (current-buffer) t '(tm-vm/view-message)
 570               '(tm-vm/view-mesage reading-message))
 571   (let* ((mp (car vm-message-pointer))
 572          (ct  (vm-get-header-contents mp "Content-Type:"))
 573          (cte (vm-get-header-contents mp "Content-Transfer-Encoding:"))
 574          (exposed (= (point-min) (vm-start-of mp))))
 575     (save-restriction
 576       (vm-widen-page)
 577       ;; vm-widen-page hides exposed header if pages are delimited.
 578       ;; So, here we expose it again.
 579       (if exposed
 580           (narrow-to-region (vm-start-of mp) (point-max)))
 581       (select-window (vm-get-buffer-window (current-buffer)))
 582       (mime/viewer-mode nil
 583                         (mime/parse-Content-Type (or ct ""))
 584                         cte)
 585       )))
 586
 587 (set-alist 'mime-viewer/quitting-method-alist
 588            'vm-mode
 589            'tm-vm/quit-view-message)
 590
 591 (set-alist 'mime-viewer/quitting-method-alist
 592            'vm-virtual-mode
 593            'tm-vm/quit-view-message)
 594
 595
 596 ;;; @ for tm-partial
 597 ;;;
 598
 599 (call-after-loaded
 600  'tm-partial
 601  (function
 602   (lambda ()
 603     (set-atype 'mime/content-decoding-condition
 604                '((type . "message/partial")
 605                  (method . mime-article/grab-message/partials)
 606                  (major-mode . vm-mode)
 607                  (summary-buffer-exp . vm-summary-buffer)
 608                  ))
 609     (set-alist 'tm-partial/preview-article-method-alist
 610                'vm-mode
 611                (function
 612                 (lambda ()
 613                   (tm-vm/view-message)
 614                   )))
 615     )))
 616
 617
 618 ;;; @ for tm-edit
 619 ;;;
 620
 621 ;;; @@ for multipart/digest
 622 ;;;
 623
 624 (defvar tm-vm/forward-message-hook nil
 625   "*List of functions called after a Mail mode buffer has been
 626 created to forward a message in message/rfc822 type format.
 627 If `vm-forwarding-digest-type' is \"rfc1521\", tm-vm runs this
 628 hook instead of `vm-forward-message-hook'.")
 629
 630 (defvar tm-vm/send-digest-hook nil
 631   "*List of functions called after a Mail mode buffer has been
 632 created to send a digest in multipart/digest type format.
 633 If `vm-digest-send-type' is \"rfc1521\", tm-vm runs this hook
 634 instead of `vm-send-digest-hook'.")
 635
 636 (defun tm-vm/enclose-messages (mlist)
 637   "Enclose the messages in MLIST as multipart/digest.
 638 The resulting digest is inserted at point in the current buffer.
 639
 640 MLIST should be a list of message structs (real or virtual).
 641 These are the messages that will be enclosed."
 642   (if mlist
 643       (let ((digest (consp (cdr mlist)))
 644             m)
 645         (save-restriction
 646           (narrow-to-region (point) (point))
 647           (while mlist
 648             (setq m (vm-real-message-of (car mlist)))
 649             (mime-editor/insert-tag "message" "rfc822")
 650             (tm-mail/insert-message m)
 651             (goto-char (point-max))
 652             (setq mlist (cdr mlist)))
 653           (if digest
 654               (mime-editor/enclose-digest-region (point-min) (point-max)))
 655           ))))
 656
 657 (defun tm-vm/forward-message ()
 658   "Forward the current message to one or more recipients.
 659 You will be placed in a Mail mode buffer as you would with a
 660 reply, but you must fill in the To: header and perhaps the
 661 Subject: header manually."
 662   (interactive)
 663   (if (not (equal vm-forwarding-digest-type "rfc1521"))
 664       (vm-forward-message)
 665     (vm-follow-summary-cursor)
 666     (vm-select-folder-buffer)
 667     (vm-check-for-killed-summary)
 668     (vm-error-if-folder-empty)
 669     (if (eq last-command 'vm-next-command-uses-marks)
 670         (let ((vm-digest-send-type vm-forwarding-digest-type))
 671           (setq this-command 'vm-next-command-uses-marks)
 672           (command-execute 'tm-vm/send-digest))
 673       (let ((dir default-directory)
 674             (mp vm-message-pointer))
 675         (save-restriction
 676           (widen)
 677           (vm-mail-internal
 678            (format "forward of %s's note re: %s"
 679                    (vm-su-full-name (car vm-message-pointer))
 680                    (vm-su-subject (car vm-message-pointer)))
 681            nil
 682            (and vm-forwarding-subject-format
 683                 (let ((vm-summary-uninteresting-senders nil))
 684                   (vm-sprintf 'vm-forwarding-subject-format (car mp)))))
 685           (make-local-variable 'vm-forward-list)
 686           (setq vm-system-state 'forwarding
 687                 vm-forward-list (list (car mp))
 688                 default-directory dir)
 689           (goto-char (point-min))
 690           (re-search-forward
 691            (concat "^" (regexp-quote mail-header-separator) "\n") nil 0)
 692           (tm-vm/enclose-messages vm-forward-list)
 693           (mail-position-on-field "To"))
 694         (run-hooks 'tm-vm/forward-message-hook)
 695         (run-hooks 'vm-mail-mode-hook)))))
 696
 697 (defun tm-vm/send-digest (&optional prefix)
 698   "Send a digest of all messages in the current folder to recipients.
 699 The type of the digest is specified by the variable vm-digest-send-type.
 700 You will be placed in a Mail mode buffer as is usual with replies, but you
 701 must fill in the To: and Subject: headers manually.
 702
 703 If invoked on marked messages (via vm-next-command-uses-marks),
 704 only marked messages will be put into the digest."
 705   (interactive "P")
 706   (if (not (equal vm-digest-send-type "rfc1521"))
 707       (vm-send-digest prefix)
 708     (vm-select-folder-buffer)
 709     (vm-check-for-killed-summary)
 710     (vm-error-if-folder-empty)
 711     (let ((dir default-directory)
 712           (mp vm-message-pointer)
 713           (mlist (if (eq last-command 'vm-next-command-uses-marks)
 714                      (vm-select-marked-or-prefixed-messages 0)
 715                    vm-message-list))
 716           start)
 717       (save-restriction
 718         (widen)
 719         (vm-mail-internal (format "digest from %s" (buffer-name)))
 720         (setq vm-system-state 'forwarding
 721               vm-forward-list mlist
 722               default-directory dir)
 723         (goto-char (point-min))
 724         (re-search-forward (concat "^" (regexp-quote mail-header-separator)
 725                                    "\n"))
 726         (goto-char (match-end 0))
 727         (setq start (point)
 728               mp mlist)
 729         (vm-unsaved-message "Building %s digest..." vm-digest-send-type)
 730         (tm-vm/enclose-messages mlist)
 731         (goto-char start)
 732         (setq mp mlist)
 733         (if prefix
 734           (progn
 735             (mime-editor/insert-tag "text" "plain")
 736             (vm-unsaved-message "Building digest preamble...")
 737             (while mp
 738               (let ((vm-summary-uninteresting-senders nil))
 739                 (insert (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n"))
 740               (if vm-digest-center-preamble
 741                   (progn
 742                     (forward-char -1)
 743                     (center-line)
 744                     (forward-char 1)))
 745               (setq mp (cdr mp)))))
 746         (mail-position-on-field "To")
 747         (message "Building %s digest... done" vm-digest-send-type)))
 748     (run-hooks 'tm-vm/send-digest-hook)
 749     (run-hooks 'vm-mail-mode-hook)))
 750
 751 (substitute-key-definition 'vm-forward-message
 752                            'tm-vm/forward-message vm-mode-map)
 753 (substitute-key-definition 'vm-send-digest
 754                            'tm-vm/send-digest vm-mode-map)
 755
 756 ;;; @@ for message/rfc822
 757 ;;;
 758 \f
 759
 760 ;;; @@ setting
 761 ;;;
 762
 763 (defvar tm-vm/use-xemacs-popup-menu t)
 764
 765 ;;; modified by Steven L. Baur <steve@miranova.com>
 766 ;;;     1995/12/6 (c.f. [tm-en:209])
 767 (defun mime-editor/attach-to-vm-mode-menu ()
 768   "Arrange to attach MIME editor's popup menu to VM's"
 769   (if (boundp 'vm-menu-mail-menu)
 770       (progn
 771         (setq vm-menu-mail-menu
 772               (append vm-menu-mail-menu
 773                       (list "----"
 774                             mime-editor/popup-menu-for-xemacs)))
 775         (remove-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu)
 776         )))
 777
 778 (call-after-loaded
 779  'tm-edit
 780  (function
 781   (lambda ()
 782     (autoload 'tm-mail/insert-message "tm-mail")
 783     (set-alist 'mime-editor/message-inserter-alist
 784                'mail-mode (function tm-mail/insert-message))
 785     (if (and (string-match "XEmacs\\|Lucid" emacs-version)
 786              tm-vm/use-xemacs-popup-menu)
 787         (add-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu)
 788       )
 789     )))
 790
 791 (call-after-loaded
 792  'mime-setup
 793  (function
 794   (lambda ()
 795     (setq vm-forwarding-digest-type "rfc1521")
 796     (setq vm-digest-send-type "rfc1521")
 797     )))
 798
 799
 800 ;;; @ for BBDB
 801 ;;;
 802
 803 (call-after-loaded
 804  'bbdb
 805  (function
 806   (lambda ()
 807     (require 'bbdb-vm)
 808     (require 'tm-bbdb)
 809     (or (fboundp 'tm:bbdb/vm-update-record)
 810         (fset 'tm:bbdb/vm-update-record
 811               (symbol-function 'bbdb/vm-update-record)))
 812     (defun bbdb/vm-update-record (&optional offer-to-create)
 813       (vm-select-folder-buffer)
 814       (if (and (tm-vm/system-state)
 815                mime::article/preview-buffer
 816                (get-buffer mime::article/preview-buffer))
 817           (tm-bbdb/update-record offer-to-create)
 818         (tm:bbdb/vm-update-record offer-to-create)
 819         ))
 820     (remove-hook 'vm-select-message-hook 'bbdb/vm-update-record)
 821     (remove-hook 'vm-show-message-hook 'bbdb/vm-update-record)
 822     (add-hook 'tm-vm/select-message-hook 'bbdb/vm-update-record)
 823     )))
 824
 825
 826 ;;; @ end
 827 ;;;
 828
 829 (provide 'tm-vm)
 830
 831 (run-hooks 'tm-vm-load-hook)
 832
 833 ;;; tm-vm.el ends here.