tm-vm.el

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