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