tm-vm.el

   1 ;;; tm-vm.el --- tm-MUA (MIME Extension module) for VM
   2
   3 ;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc.
   4
   5 ;; Author: MASUTANI Yasuhiro <masutani@me.es.osaka-u.ac.jp>
   6 ;;         Kenji Wakamiya <wkenji@flab.fujitsu.co.jp>
   7 ;;         MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;         Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
   9 ;;         Oscar Figueiredo <figueire@lspsun2.epfl.ch>
  10 ;; Maintainer: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
  11 ;; Created: 1994/10/29
  12 ;; Version: $Revision: 7.57 $
  13 ;; Keywords: mail, MIME, multimedia, multilingual, encoded-word
  14
  15 ;; This file is part of tm (Tools for MIME).
  16
  17 ;; This program is free software; you can redistribute it and/or
  18 ;; modify it under the terms of the GNU General Public License as
  19 ;; published by the Free Software Foundation; either version 2, or (at
  20 ;; your option) any later version.
  21
  22 ;; This program is distributed in the hope that it will be useful, but
  23 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  24 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  25 ;; General Public License for more details.
  26
  27 ;; You should have received a copy of the GNU General Public License
  28 ;; along with This program.  If not, write to the Free Software
  29 ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  30
  31 ;;; Commentary:
  32
  33 ;;      Plese insert `(require 'tm-vm)' in your ~/.vm file.
  34
  35 ;;; Code:
  36
  37 (require 'tm-view)
  38 (require 'vm)
  39
  40 (defconst tm-vm/RCS-ID
  41   "$Id: tm-vm.el,v 7.57 1996/08/13 13:12:50 morioka Exp $")
  42 (defconst tm-vm/version (get-version-string tm-vm/RCS-ID))
  43
  44 (define-key vm-mode-map "Z" 'tm-vm/view-message)
  45 (define-key vm-mode-map "T" 'tm-vm/decode-message-header)
  46 (define-key vm-mode-map "\et" 'tm-vm/toggle-preview-mode)
  47
  48 (defvar tm-vm/use-original-url-button nil
  49   "*If it is t, use original URL button instead of tm's.")
  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.
 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               (if (and tm-vm/use-original-url-button
 235                        vm-use-menus (vm-menu-support-possible-p))
 236                   (vm-energize-urls))
 237               ;; 1996/2/16, fixed by
 238               ;;    Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 239               ;; Highlight message (and display XFace if supported)
 240               (if (or vm-highlighted-header-regexp
 241                       (and (vm-xemacs-p) vm-use-lucid-highlighting))
 242                   (vm-highlight-headers))
 243               (if (and vm-use-menus (vm-menu-support-possible-p))
 244                   (vm-energize-headers))              ;;
 245               (goto-char (point-min))
 246               (narrow-to-region (point) (search-forward "\n\n" nil t))
 247               ))
 248         ;; don't do MIME processing. decode header only.
 249         (let (buffer-read-only)
 250           (mime/decode-message-header))
 251         )
 252     ;; don't preview; do nothing.
 253     )
 254   (tm-vm/display-preview-buffer)
 255   (run-hooks 'tm-vm/select-message-hook))
 256
 257 (defun tm-vm/show-current-message ()
 258   (if mime::preview/article-buffer
 259       (set-buffer mime::preview/article-buffer)
 260     (vm-select-folder-buffer))
 261   ;; Now current buffer is folder buffer.
 262   (if (or t ; mime/viewer-mode doesn't support narrowing yet.
 263           (null vm-preview-lines)
 264           (and (not vm-preview-read-messages)
 265                (not (vm-new-flag
 266                      (car vm-message-pointer)))
 267                (not (vm-unread-flag
 268                      (car vm-message-pointer)))))
 269       (save-excursion
 270         (set-buffer mime::article/preview-buffer)
 271         (save-excursion
 272           (save-excursion
 273             (goto-char (point-min))
 274             (widen))
 275           ;; narrow to page; mime/viewer-mode doesn't support narrowing yet.
 276           )))
 277   (if (vm-get-visible-buffer-window mime::article/preview-buffer)
 278       (progn
 279         (setq tm-vm/system-state 'reading)
 280         (if (vm-new-flag (car vm-message-pointer))
 281             (vm-set-new-flag (car vm-message-pointer) nil))
 282         (if (vm-unread-flag (car vm-message-pointer))
 283             (vm-set-unread-flag (car vm-message-pointer) nil))
 284         (vm-update-summary-and-mode-line)
 285         (tm-vm/howl-if-eom))
 286     (vm-update-summary-and-mode-line)))
 287
 288 (defun tm-vm/toggle-preview-mode ()
 289   (interactive)
 290   (vm-select-folder-buffer)
 291   (vm-display (current-buffer) t (list this-command)
 292               (list this-command 'reading-message))
 293   (if tm-vm/automatic-mime-preview
 294       (setq tm-vm/automatic-mime-preview nil
 295             tm-vm/system-state nil)
 296     (setq tm-vm/automatic-mime-preview t
 297           tm-vm/system-state nil)
 298     (save-restriction
 299        (vm-widen-page)
 300        (let* ((mp (car vm-message-pointer))
 301               (exposed (= (point-min) (vm-start-of mp))))
 302          (if (or (not tm-vm/strict-mime)
 303                  (vm-get-header-contents mp "MIME-Version:"))
 304              ;; do MIME processiong.
 305              (progn
 306                (set (make-local-variable 'tm-vm/system-state) 'previewing)
 307                (save-window-excursion
 308                  (mime/viewer-mode)
 309                  (goto-char (point-min))
 310                  (narrow-to-region (point)
 311                                    (search-forward "\n\n" nil t))
 312                  ))
 313            ;; don't do MIME processing. decode header only.
 314            (let (buffer-read-only)
 315              (mime/decode-message-header))
 316            )
 317          ;; don't preview; do nothing.
 318          ))
 319     (tm-vm/display-preview-buffer)
 320     ))
 321
 322 (add-hook 'vm-select-message-hook 'tm-vm/preview-current-message)
 323 (add-hook 'vm-visit-folder-hook   'tm-vm/preview-current-message)
 324 \f
 325 ;;; tm-vm move commands
 326 ;;;
 327
 328 (defmacro tm-vm/save-window-excursion (&rest forms)
 329   (list 'let '((tm-vm/selected-window (selected-window)))
 330         (list 'unwind-protect
 331               (cons 'progn forms)
 332               '(if (window-live-p tm-vm/selected-window)
 333                    (select-window tm-vm/selected-window)))))
 334
 335 ;;; based on vm-scroll-forward [vm-page.el]
 336 (defun tm-vm/scroll-forward (&optional arg)
 337   (interactive "P")
 338   (let ((this-command 'vm-scroll-forward))
 339     (if (not (tm-vm/system-state))
 340         (vm-scroll-forward arg)
 341       (let* ((mp-changed (vm-follow-summary-cursor))
 342              (mbuf (or (vm-select-folder-buffer) (current-buffer)))
 343              (mwin (vm-get-buffer-window mbuf))
 344              (pbuf (and mime::article/preview-buffer
 345                         (get-buffer mime::article/preview-buffer)))
 346              (pwin (and pbuf (vm-get-buffer-window pbuf)))
 347              (was-invisible (and (null mwin) (null pwin)))
 348              )
 349         ;; now current buffer is folder buffer.
 350         (tm-vm/save-window-excursion
 351          (if (or mp-changed was-invisible)
 352              (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
 353                          (list this-command 'reading-message)))
 354          (tm-vm/display-preview-buffer)
 355          (setq mwin (vm-get-buffer-window mbuf)
 356                pwin (and pbuf (vm-get-buffer-window pbuf)))
 357          (cond
 358           ((or mp-changed was-invisible)
 359            nil
 360            )
 361           ((null pbuf)
 362            ;; preview buffer is killed.
 363            (tm-vm/preview-current-message)
 364            (vm-update-summary-and-mode-line))
 365           ((eq (tm-vm/system-state) 'previewing)
 366            (tm-vm/show-current-message))
 367           (t
 368            (select-window pwin)
 369            (set-buffer pbuf)
 370            (if (pos-visible-in-window-p (point-max) pwin)
 371                (tm-vm/next-message)
 372              ;; not end of message. scroll preview buffer only.
 373              (scroll-up)
 374              (tm-vm/howl-if-eom)
 375              (set-buffer mbuf))
 376            ))))
 377       )))
 378
 379 ;;; based on vm-scroll-backward [vm-page.el]
 380 (defun tm-vm/scroll-backward (&optional arg)
 381   (interactive "P")
 382   (let ((this-command 'vm-scroll-backward))
 383     (if (not (tm-vm/system-state))
 384         (vm-scroll-backward arg)
 385       (let* ((mp-changed (vm-follow-summary-cursor))
 386              (mbuf (or (vm-select-folder-buffer) (current-buffer)))
 387              (mwin (vm-get-buffer-window mbuf))
 388              (pbuf (and mime::article/preview-buffer
 389                         (get-buffer mime::article/preview-buffer)))
 390              (pwin (and pbuf (vm-get-buffer-window pbuf)))
 391              (was-invisible (and (null mwin) (null pwin)))
 392              )
 393         ;; now current buffer is folder buffer.
 394         (if (or mp-changed was-invisible)
 395             (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
 396                         (list this-command 'reading-message)))
 397         (tm-vm/save-window-excursion
 398          (tm-vm/display-preview-buffer)
 399          (setq mwin (vm-get-buffer-window mbuf)
 400                pwin (and pbuf (vm-get-buffer-window pbuf)))
 401          (cond
 402           (was-invisible
 403            nil
 404            )
 405           ((null pbuf)
 406            ;; preview buffer is killed.
 407            (tm-vm/preview-current-message)
 408            (vm-update-summary-and-mode-line))
 409           ((eq (tm-vm/system-state) 'previewing)
 410            (tm-vm/show-current-message))
 411           (t
 412            (select-window pwin)
 413            (set-buffer pbuf)
 414            (if (pos-visible-in-window-p (point-min) pwin)
 415                nil
 416              ;; scroll preview buffer only.
 417              (scroll-down)
 418              (set-buffer mbuf))
 419            ))))
 420       )))
 421
 422 ;;; based on vm-beginning-of-message [vm-page.el]
 423 (defun tm-vm/beginning-of-message ()
 424   "Moves to the beginning of the current message."
 425   (interactive)
 426   (if (not (tm-vm/system-state))
 427       (progn
 428         (setq this-command 'vm-beginning-of-message)
 429         (vm-beginning-of-message))
 430     (vm-follow-summary-cursor)
 431     (vm-select-folder-buffer)
 432     (vm-check-for-killed-summary)
 433     (vm-error-if-folder-empty)
 434     (let ((mbuf (current-buffer))
 435           (pbuf (and mime::article/preview-buffer
 436                      (get-buffer mime::article/preview-buffer))))
 437       (if (null pbuf)
 438           (progn
 439             (tm-vm/preview-current-message)
 440             (setq pbuf (get-buffer mime::article/preview-buffer))
 441             ))
 442       (vm-display mbuf t '(vm-beginning-of-message)
 443                   '(vm-beginning-of-message reading-message))
 444       (tm-vm/display-preview-buffer)
 445       (set-buffer pbuf)
 446       (tm-vm/save-window-excursion
 447        (select-window (vm-get-buffer-window pbuf))
 448        (push-mark)
 449        (goto-char (point-min))
 450        ))))
 451
 452 ;;; based on vm-end-of-message [vm-page.el]
 453 (defun tm-vm/end-of-message ()
 454   "Moves to the end of the current message."
 455   (interactive)
 456   (if (not (tm-vm/system-state))
 457       (progn
 458         (setq this-command 'vm-end-of-message)
 459         (vm-end-of-message))
 460     (vm-follow-summary-cursor)
 461     (vm-select-folder-buffer)
 462     (vm-check-for-killed-summary)
 463     (vm-error-if-folder-empty)
 464     (let ((mbuf (current-buffer))
 465           (pbuf (and mime::article/preview-buffer
 466                      (get-buffer mime::article/preview-buffer))))
 467       (if (null pbuf)
 468           (progn
 469             (tm-vm/preview-current-message)
 470             (setq pbuf (get-buffer mime::article/preview-buffer))
 471             ))
 472       (vm-display mbuf t '(vm-end-of-message)
 473                   '(vm-end-of-message reading-message))
 474       (tm-vm/display-preview-buffer)
 475       (set-buffer pbuf)
 476       (tm-vm/save-window-excursion
 477        (select-window (vm-get-buffer-window pbuf))
 478        (push-mark)
 479        (goto-char (point-max))
 480        ))))
 481
 482 ;;; based on vm-howl-if-eom [vm-page.el]
 483 (defun tm-vm/howl-if-eom ()
 484   (let* ((pbuf (or mime::article/preview-buffer (current-buffer)))
 485          (pwin (and (vm-get-visible-buffer-window pbuf))))
 486     (and pwin
 487          (save-excursion
 488            (save-window-excursion
 489              (condition-case ()
 490                  (let ((next-screen-context-lines 0))
 491                    (select-window pwin)
 492                    (save-excursion
 493                      (save-window-excursion
 494                        (let ((scroll-in-place-replace-original nil))
 495                          (scroll-up))))
 496                    nil)
 497                (error t))))
 498          (tm-vm/emit-eom-blurb)
 499          )))
 500
 501 ;;; based on vm-emit-eom-blurb [vm-page.el]
 502 (defun tm-vm/emit-eom-blurb ()
 503   (save-excursion
 504     (if mime::preview/article-buffer
 505         (set-buffer mime::preview/article-buffer))
 506     (vm-emit-eom-blurb)))
 507
 508 ;;; based on vm-quit [vm-folder.el]
 509 (defun tm-vm/quit ()
 510   (interactive)
 511   (save-excursion
 512     (vm-select-folder-buffer)
 513     (if (and mime::article/preview-buffer
 514              (get-buffer mime::article/preview-buffer))
 515         (kill-buffer mime::article/preview-buffer)))
 516   (vm-quit))
 517
 518 (substitute-key-definition 'vm-scroll-forward
 519                            'tm-vm/scroll-forward vm-mode-map)
 520 (substitute-key-definition 'vm-scroll-backward
 521                            'tm-vm/scroll-backward vm-mode-map)
 522 (substitute-key-definition 'vm-beginning-of-message
 523                            'tm-vm/beginning-of-message vm-mode-map)
 524 (substitute-key-definition 'vm-end-of-message
 525                            'tm-vm/end-of-message vm-mode-map)
 526 (substitute-key-definition 'vm-quit
 527                            'tm-vm/quit vm-mode-map)
 528
 529 ;;; based on vm-next-message [vm-motion.el]
 530 (defun tm-vm/next-message ()
 531   (set-buffer mime::preview/article-buffer)
 532   (let ((this-command 'vm-next-message)
 533         (owin (selected-window))
 534         (vm-preview-lines nil)
 535         )
 536     (vm-next-message 1 nil t)
 537     (if (window-live-p owin)
 538         (select-window owin))))
 539
 540 ;;; based on vm-previous-message [vm-motion.el]
 541 (defun tm-vm/previous-message ()
 542   (set-buffer mime::preview/article-buffer)
 543   (let ((this-command 'vm-previous-message)
 544         (owin (selected-window))
 545         (vm-preview-lines nil)
 546         )
 547     (vm-previous-message 1 nil t)
 548     (if (window-live-p owin)
 549         (select-window owin))))
 550
 551 (set-alist 'mime-viewer/over-to-previous-method-alist
 552            'vm-mode 'tm-vm/previous-message)
 553 (set-alist 'mime-viewer/over-to-next-method-alist
 554            'vm-mode 'tm-vm/next-message)
 555 (set-alist 'mime-viewer/over-to-previous-method-alist
 556            'vm-virtual-mode 'tm-vm/previous-message)
 557 (set-alist 'mime-viewer/over-to-next-method-alist
 558            'vm-virtual-mode 'tm-vm/next-message)
 559
 560 ;;; @@ vm-yank-message
 561 ;;;
 562 ;; 1996/3/28 by Oscar Figueiredo <figueire@lspsun16.epfl.ch>
 563
 564 (require 'vm-reply)
 565
 566 (defun vm-yank-message (&optional message)
 567   "Yank message number N into the current buffer at point.
 568 When called interactively N is always read from the minibuffer.  When
 569 called non-interactively the first argument is expected to be a
 570 message struct.
 571
 572 This function originally provided by vm-reply has been patched for TM in
 573 order to provide better citation of MIME messages : if a MIME Preview
 574 buffer is displayed for the message then its contents are inserted
 575 instead of the raw message.
 576
 577 This command is meant to be used in VM created Mail mode buffers; the
 578 yanked message comes from the mail buffer containing the message you
 579 are replying to, forwarding, or invoked VM's mail command from.
 580
 581 All message headers are yanked along with the text.  Point is
 582 left before the inserted text, the mark after.  Any hook
 583 functions bound to mail-citation-hook are run, after inserting
 584 the text and setting point and mark.  For backward compatibility,
 585 if mail-citation-hook is set to nil, `mail-yank-hooks' is run
 586 instead.
 587
 588 If mail-citation-hook and mail-yank-hooks are both nil, this
 589 default action is taken: the yanked headers are trimmed as
 590 specified by vm-included-text-headers and
 591 vm-included-text-discard-header-regexp, and the value of
 592 vm-included-text-prefix is prepended to every yanked line."
 593   (interactive
 594    (list
 595     ;; What we really want for the first argument is a message struct,
 596     ;; but if called interactively, we let the user type in a message
 597     ;; number instead.
 598     (let (mp default
 599              (result 0)
 600              prompt
 601              (last-command last-command)
 602              (this-command this-command))
 603       (if (bufferp vm-mail-buffer)
 604           (save-excursion
 605             (vm-select-folder-buffer)
 606             (setq default (and vm-message-pointer
 607                                (vm-number-of (car vm-message-pointer)))
 608                   prompt (if default
 609                              (format "Yank message number: (default %s) "
 610                                      default)
 611                            "Yank message number: "))
 612             (while (zerop result)
 613               (setq result (read-string prompt))
 614               (and (string= result "") default (setq result default))
 615               (setq result (string-to-int result)))
 616             (if (null (setq mp (nthcdr (1- result) vm-message-list)))
 617                 (error "No such message."))
 618             (car mp))
 619         nil))))
 620   (if (null message)
 621       (if mail-reply-buffer
 622           (tm-vm/yank-content)
 623         (error "This is not a VM Mail mode buffer."))
 624     (if (null (buffer-name vm-mail-buffer))
 625         (error "The folder buffer containing message %d has been killed."
 626                (vm-number-of message)))
 627     (save-window-excursion
 628       (tm-vm/view-message))
 629     (vm-display nil nil '(vm-yank-message)
 630                 '(vm-yank-message composing-message))
 631     (setq message (vm-real-message-of message))
 632     (let ((b (current-buffer)) (start (point)) end)
 633       (save-restriction
 634         (widen)
 635         (save-excursion
 636           (set-buffer (vm-buffer-of message))
 637           (let* ((mbuf (current-buffer))
 638                  (pbuf (and mime::article/preview-buffer
 639                             (get-buffer mime::article/preview-buffer)))
 640                  (pwin (and pbuf (save-window-excursion
 641                                  (vm-get-visible-buffer-window
 642                                   (switch-to-buffer-other-window pbuf))))))
 643             (if pwin
 644                 (if running-xemacs
 645                     (let ((tmp (generate-new-buffer "tm-vm/tmp")))
 646                       (set-buffer pbuf)
 647                       (append-to-buffer tmp (point-min) (point-max))
 648                       (set-buffer tmp)
 649                       (map-extents
 650                        '(lambda (ext maparg)
 651                           (set-extent-property ext 'begin-glyph nil)))
 652                       (append-to-buffer b (point-min) (point-max))
 653                       (setq end (vm-marker
 654                                  (+ start (length (buffer-string))) b))
 655                       (kill-buffer tmp))
 656                   (set-buffer pbuf)
 657                   (append-to-buffer b (point-min) (point-max))
 658                   (setq end (vm-marker
 659                              (+ start (length (buffer-string))) b)))
 660               (save-restriction
 661                 (widen)
 662                 (append-to-buffer
 663                  b (vm-headers-of message) (vm-text-end-of message))
 664                 (setq end
 665                       (vm-marker (+ start (- (vm-text-end-of message)
 666                                              (vm-headers-of message))) b))))))
 667         (push-mark end)
 668         (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
 669               (mail-yank-hooks (run-hooks 'mail-yank-hooks))
 670               (t (vm-mail-yank-default message)))
 671         ))
 672     ))
 673
 674 \f
 675 ;;; @ for tm-view
 676 ;;;
 677
 678 ;;; based on vm-do-reply [vm-reply.el]
 679 (defun tm-vm/do-reply (buf to-all include-text)
 680   (save-excursion
 681     (set-buffer buf)
 682     (let ((dir default-directory)
 683           to cc subject mp in-reply-to references newsgroups)
 684       (cond ((setq to
 685                    (let ((reply-to (rfc822/get-field-body "Reply-To")))
 686                      (if (vm-ignored-reply-to reply-to)
 687                          nil
 688                        reply-to))))
 689             ((setq to (rfc822/get-field-body "From")))
 690             ;; (t (error "No From: or Reply-To: header in message"))
 691             )
 692       (if to-all
 693           (setq cc (delq nil (cons cc (rfc822/get-field-bodies '("To" "Cc"))))
 694                 cc (mapconcat 'identity cc ","))
 695         )
 696       (setq subject (rfc822/get-field-body "Subject"))
 697       (and subject vm-reply-subject-prefix
 698            (let ((case-fold-search t))
 699              (not
 700               (equal
 701                (string-match (regexp-quote vm-reply-subject-prefix)
 702                              subject)
 703                0)))
 704            (setq subject (concat vm-reply-subject-prefix subject)))
 705       (setq in-reply-to (rfc822/get-field-body "Message-Id")
 706             references (nconc
 707                         (rfc822/get-field-bodies '("References" "In-Reply-To"))
 708                         (list in-reply-to))
 709             newsgroups (list (or (and to-all
 710                                       (rfc822/get-field-body "Followup-To"))
 711                                  (rfc822/get-field-body "Newsgroups"))))
 712       (setq to (vm-parse-addresses to)
 713             cc (vm-parse-addresses cc))
 714       (if vm-reply-ignored-addresses
 715           (setq to (vm-strip-ignored-addresses to)
 716                 cc (vm-strip-ignored-addresses cc)))
 717       (setq to (vm-delete-duplicates to nil t))
 718       (setq cc (vm-delete-duplicates
 719                 (append (vm-delete-duplicates cc nil t)
 720                         to (copy-sequence to))
 721                 t t))
 722       (and to (setq to (mapconcat 'identity to ",\n ")))
 723       (and cc (setq cc (mapconcat 'identity cc ",\n ")))
 724       (and (null to) (setq to cc cc nil))
 725       (setq references (delq nil references)
 726             references (mapconcat 'identity references " ")
 727             references (vm-parse references "[^<]*\\(<[^>]+>\\)")
 728             references (vm-delete-duplicates references)
 729             references (if references (mapconcat 'identity references "\n\t")))
 730       (setq newsgroups (delq nil newsgroups)
 731             newsgroups (mapconcat 'identity newsgroups ",")
 732             newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
 733             newsgroups (vm-delete-duplicates newsgroups)
 734             newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
 735       (vm-mail-internal
 736        (if to
 737            (format "reply to %s%s"
 738                    (rfc822/full-name-string
 739                     (car (rfc822/parse-address
 740                           (rfc822/lexical-analyze to))))
 741                    (if cc ", ..." "")))
 742        to subject in-reply-to cc references newsgroups)
 743       (setq mail-reply-buffer buf
 744             ;; vm-system-state 'replying
 745             default-directory dir))
 746     (if include-text
 747         (save-excursion
 748           (goto-char (point-min))
 749           (let ((case-fold-search nil))
 750             (re-search-forward
 751              (concat "^" (regexp-quote mail-header-separator) "$") nil 0))
 752           (forward-char 1)
 753           (tm-vm/yank-content)))
 754     (run-hooks 'vm-reply-hook)
 755     (run-hooks 'vm-mail-mode-hook)
 756     ))
 757
 758 (defun tm-vm/following-method (buf)
 759   (tm-vm/do-reply buf 'to-all 'include-text)
 760   )
 761
 762 (defun tm-vm/yank-content ()
 763   (interactive)
 764   (let ((this-command 'vm-yank-message))
 765     (vm-display nil nil '(vm-yank-message)
 766                 '(vm-yank-message composing-message))
 767     (save-restriction
 768       (narrow-to-region (point)(point))
 769       (insert-buffer mail-reply-buffer)
 770       (goto-char (point-max))
 771       (push-mark)
 772       (goto-char (point-min)))
 773     (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
 774           (mail-yank-hooks (run-hooks 'mail-yank-hooks))
 775           (t (mail-indent-citation)))
 776     ))
 777
 778 (set-alist 'mime-viewer/following-method-alist
 779            'vm-mode
 780            (function tm-vm/following-method))
 781 (set-alist 'mime-viewer/following-method-alist
 782            'vm-virtual-mode
 783            (function tm-vm/following-method))
 784
 785
 786 (defun tm-vm/quit-view-message ()
 787   "Quit MIME-viewer and go back to VM.
 788 This function is called by `mime-viewer/quit' command via
 789 `mime-viewer/quitting-method-alist'."
 790   (if (get-buffer mime/output-buffer-name)
 791       (vm-undisplay-buffer mime/output-buffer-name))
 792   (if (and tm-vm/automatic-mime-preview
 793            (save-excursion
 794              (set-buffer mime::preview/article-buffer)
 795              vm-summary-buffer))
 796       (switch-to-buffer mime::preview/article-buffer)
 797     (mime-viewer/kill-buffer)
 798     (vm-select-folder-buffer)
 799     (setq tm-vm/system-state nil))
 800   (vm-display (current-buffer) t (list this-command)
 801               (list this-command 'reading-message))
 802   (tm-vm/display-preview-buffer)
 803   )
 804
 805 (defun tm-vm/view-message ()
 806   "Decode and view MIME encoded message, under VM."
 807   (interactive)
 808   (vm-follow-summary-cursor)
 809   (vm-select-folder-buffer)
 810   (vm-check-for-killed-summary)
 811   (vm-error-if-folder-empty)
 812   (vm-display (current-buffer) t '(tm-vm/view-message)
 813               '(tm-vm/view-mesage reading-message))
 814   (let* ((mp (car vm-message-pointer))
 815          (ct  (vm-get-header-contents mp "Content-Type:"))
 816          (cte (vm-get-header-contents mp "Content-Transfer-Encoding:"))
 817          (exposed (= (point-min) (vm-start-of mp))))
 818     (save-restriction
 819       (vm-widen-page)
 820       ;; vm-widen-page hides exposed header if pages are delimited.
 821       ;; So, here we expose it again.
 822       (if exposed
 823           (narrow-to-region (vm-start-of mp) (point-max)))
 824       (select-window (vm-get-buffer-window (current-buffer)))
 825       (mime/viewer-mode nil
 826                         (mime/parse-Content-Type (or ct ""))
 827                         cte)
 828       )))
 829
 830 (set-alist 'mime-viewer/quitting-method-alist
 831            'vm-mode
 832            'tm-vm/quit-view-message)
 833
 834 (set-alist 'mime-viewer/quitting-method-alist
 835            'vm-virtual-mode
 836            'tm-vm/quit-view-message)
 837
 838
 839 ;;; @ for tm-partial
 840 ;;;
 841
 842 (call-after-loaded
 843  'tm-partial
 844  (function
 845   (lambda ()
 846     (set-atype 'mime/content-decoding-condition
 847                '((type . "message/partial")
 848                  (method . mime-article/grab-message/partials)
 849                  (major-mode . vm-mode)
 850                  (summary-buffer-exp . vm-summary-buffer)
 851                  ))
 852     (set-alist 'tm-partial/preview-article-method-alist
 853                'vm-mode
 854                (function
 855                 (lambda ()
 856                   (tm-vm/view-message)
 857                   )))
 858     )))
 859
 860
 861 ;;; @ for tm-edit
 862 ;;;
 863
 864 ;;; @@ for multipart/digest
 865 ;;;
 866
 867 (defvar tm-vm/forward-message-hook nil
 868   "*List of functions called after a Mail mode buffer has been
 869 created to forward a message in message/rfc822 type format.
 870 If `vm-forwarding-digest-type' is \"rfc1521\", tm-vm runs this
 871 hook instead of `vm-forward-message-hook'.")
 872
 873 (defvar tm-vm/send-digest-hook nil
 874   "*List of functions called after a Mail mode buffer has been
 875 created to send a digest in multipart/digest type format.
 876 If `vm-digest-send-type' is \"rfc1521\", tm-vm runs this hook
 877 instead of `vm-send-digest-hook'.")
 878
 879 (defun tm-vm/enclose-messages (mlist &optional preamble)
 880   "Enclose the messages in MLIST as multipart/digest.
 881 The resulting digest is inserted at point in the current buffer.
 882
 883 MLIST should be a list of message structs (real or virtual).
 884 These are the messages that will be enclosed."
 885   (if mlist
 886       (let ((digest (consp (cdr mlist)))
 887             (mp mlist)
 888             m)
 889         (save-restriction
 890           (narrow-to-region (point) (point))
 891           (while mlist
 892             (setq m (vm-real-message-of (car mlist)))
 893             (mime-editor/insert-tag "message" "rfc822")
 894             (tm-mail/insert-message m)
 895             (goto-char (point-max))
 896             (setq mlist (cdr mlist)))
 897           (if preamble
 898               (progn
 899                 (goto-char (point-min))
 900                 (mime-editor/insert-tag "text" "plain")
 901                 (vm-unsaved-message "Building digest preamble...")
 902                 (while mp
 903                   (let ((vm-summary-uninteresting-senders nil))
 904                     (insert
 905                      (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n"))
 906                   (if vm-digest-center-preamble
 907                       (progn
 908                         (forward-char -1)
 909                         (center-line)
 910                         (forward-char 1)))
 911                   (setq mp (cdr mp)))))
 912           (if digest
 913               (mime-editor/enclose-digest-region (point-min) (point-max)))
 914           ))))
 915
 916 (defun tm-vm/forward-message ()
 917   "Forward the current message to one or more recipients.
 918 You will be placed in a Mail mode buffer as you would with a
 919 reply, but you must fill in the To: header and perhaps the
 920 Subject: header manually."
 921   (interactive)
 922   (if (not (equal vm-forwarding-digest-type "rfc1521"))
 923       (vm-forward-message)
 924     (vm-follow-summary-cursor)
 925     (vm-select-folder-buffer)
 926     (vm-check-for-killed-summary)
 927     (vm-error-if-folder-empty)
 928     (if (eq last-command 'vm-next-command-uses-marks)
 929         (let ((vm-digest-send-type vm-forwarding-digest-type))
 930           (setq this-command 'vm-next-command-uses-marks)
 931           (command-execute 'tm-vm/send-digest))
 932       (let ((dir default-directory)
 933             (mp vm-message-pointer))
 934         (save-restriction
 935           (widen)
 936           (vm-mail-internal
 937            (format "forward of %s's note re: %s"
 938                    (vm-su-full-name (car vm-message-pointer))
 939                    (vm-su-subject (car vm-message-pointer)))
 940            nil
 941            (and vm-forwarding-subject-format
 942                 (let ((vm-summary-uninteresting-senders nil))
 943                   (vm-sprintf 'vm-forwarding-subject-format (car mp)))))
 944           (make-local-variable 'vm-forward-list)
 945           (setq vm-system-state 'forwarding
 946                 vm-forward-list (list (car mp))
 947                 default-directory dir)
 948           (goto-char (point-min))
 949           (re-search-forward
 950            (concat "^" (regexp-quote mail-header-separator) "\n") nil 0)
 951           (tm-vm/enclose-messages vm-forward-list)
 952           (mail-position-on-field "To"))
 953         (run-hooks 'tm-vm/forward-message-hook)
 954         (run-hooks 'vm-mail-mode-hook)))))
 955
 956 (defun tm-vm/send-digest (&optional arg)
 957   "Send a digest of all messages in the current folder to recipients.
 958 The type of the digest is specified by the variable vm-digest-send-type.
 959 You will be placed in a Mail mode buffer as is usual with replies, but you
 960 must fill in the To: and Subject: headers manually.
 961
 962 If invoked on marked messages (via vm-next-command-uses-marks),
 963 only marked messages will be put into the digest."
 964   (interactive "P")
 965   (if (not (equal vm-digest-send-type "rfc1521"))
 966       (vm-send-digest arg)
 967     (vm-select-folder-buffer)
 968     (vm-check-for-killed-summary)
 969     (vm-error-if-folder-empty)
 970     (let ((dir default-directory)
 971           (vm-forward-list (if (eq last-command 'vm-next-command-uses-marks)
 972                                (vm-select-marked-or-prefixed-messages 0)
 973                              vm-message-list))
 974           start)
 975       (save-restriction
 976         (widen)
 977         (vm-mail-internal (format "digest from %s" (buffer-name)))
 978         (setq vm-system-state 'forwarding
 979               default-directory dir)
 980         (goto-char (point-min))
 981         (re-search-forward (concat "^" (regexp-quote mail-header-separator)
 982                                    "\n"))
 983         (goto-char (match-end 0))
 984         (vm-unsaved-message "Building %s digest..." vm-digest-send-type)
 985         (tm-vm/enclose-messages vm-forward-list arg)
 986         (mail-position-on-field "To")
 987         (message "Building %s digest... done" vm-digest-send-type)))
 988     (run-hooks 'tm-vm/send-digest-hook)
 989     (run-hooks 'vm-mail-mode-hook)))
 990
 991 (substitute-key-definition 'vm-forward-message
 992                            'tm-vm/forward-message vm-mode-map)
 993 (substitute-key-definition 'vm-send-digest
 994                            'tm-vm/send-digest vm-mode-map)
 995 \f
 996
 997 ;;; @@ setting
 998 ;;;
 999
1000 (defvar tm-vm/use-xemacs-popup-menu t)
1001
1002 ;;; modified by Steven L. Baur <steve@miranova.com>
1003 ;;;     1995/12/6 (c.f. [tm-en:209])
1004 (defun mime-editor/attach-to-vm-mode-menu ()
1005   "Arrange to attach MIME editor's popup menu to VM's"
1006   (if (boundp 'vm-menu-mail-menu)
1007       (progn
1008         (setq vm-menu-mail-menu
1009               (append vm-menu-mail-menu
1010                       (list "----"
1011                             mime-editor/popup-menu-for-xemacs)))
1012         (remove-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu)
1013         )))
1014
1015 (call-after-loaded
1016  'tm-edit
1017  (function
1018   (lambda ()
1019     (autoload 'tm-mail/insert-message "tm-mail")
1020     (set-alist 'mime-editor/message-inserter-alist
1021                'mail-mode (function tm-mail/insert-message))
1022     (set-alist 'mime-editor/split-message-sender-alist
1023                'mail-mode (function
1024                            (lambda ()
1025                              (interactive)
1026                              (sendmail-send-it)
1027                              )))
1028     (if (and (string-match "XEmacs\\|Lucid" emacs-version)
1029              tm-vm/use-xemacs-popup-menu)
1030         (add-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu)
1031       )
1032     )))
1033
1034 (call-after-loaded
1035  'mime-setup
1036  (function
1037   (lambda ()
1038     (setq vm-forwarding-digest-type "rfc1521")
1039     (setq vm-digest-send-type "rfc1521")
1040     )))
1041
1042
1043 ;;; @ for BBDB
1044 ;;;
1045
1046 (call-after-loaded
1047  'bbdb
1048  (function
1049   (lambda ()
1050     (require 'bbdb-vm)
1051     (require 'tm-bbdb)
1052     (or (fboundp 'tm:bbdb/vm-update-record)
1053         (fset 'tm:bbdb/vm-update-record
1054               (symbol-function 'bbdb/vm-update-record)))
1055     (defun bbdb/vm-update-record (&optional offer-to-create)
1056       (vm-select-folder-buffer)
1057       (if (and (tm-vm/system-state)
1058                mime::article/preview-buffer
1059                (get-buffer mime::article/preview-buffer))
1060           (tm-bbdb/update-record offer-to-create)
1061         (tm:bbdb/vm-update-record offer-to-create)
1062         ))
1063     (remove-hook 'vm-select-message-hook 'bbdb/vm-update-record)
1064     (remove-hook 'vm-show-message-hook 'bbdb/vm-update-record)
1065     (add-hook 'tm-vm/select-message-hook 'bbdb/vm-update-record)
1066     )))
1067
1068
1069 ;;; @ end
1070 ;;;
1071
1072 (provide 'tm-vm)
1073
1074 (run-hooks 'tm-vm-load-hook)
1075
1076 ;;; tm-vm.el ends here.