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.62 $
  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; see the file COPYING.  If not, write to
  29 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  30 ;; Boston, MA 02111-1307, USA.
  31
  32 ;;; Commentary:
  33
  34 ;;      Plese insert `(require 'tm-vm)' in your ~/.vm file.
  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.62 1996/08/31 14:24:35 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/use-original-url-button nil
  50   "*If it is t, use original URL button instead of tm's.")
  51
  52 (defvar tm-vm-load-hook nil
  53   "*List of functions called after tm-vm is loaded.")
  54
  55
  56 ;;; @ for MIME encoded-words
  57 ;;;
  58
  59 (defvar tm-vm/use-tm-patch nil
  60   "Does not decode encoded-words in summary buffer if it is t.
  61 If you use tiny-mime patch for VM (by RIKITAKE Kenji
  62 <kenji@reseau.toyonaka.osaka.jp>), please set it t [tm-vm.el]")
  63
  64 (or tm-vm/use-tm-patch
  65     (progn
  66 ;;;
  67 (defvar tm-vm/chop-full-name-function 'tm-vm/default-chop-full-name)
  68 (setq vm-chop-full-name-function tm-vm/chop-full-name-function)
  69
  70 (defun tm-vm/default-chop-full-name (address)
  71   (let* ((ret (vm-default-chop-full-name address))
  72          (full-name (car ret))
  73          )
  74     (if (stringp full-name)
  75         (cons (mime-eword/decode-string full-name)
  76               (cdr ret))
  77       ret)))
  78
  79 (require 'vm-summary)
  80 (or (fboundp 'tm:vm-su-subject)
  81     (fset 'tm:vm-su-subject (symbol-function 'vm-su-subject))
  82     )
  83 (defun vm-su-subject (m)
  84   (mime-eword/decode-string (tm:vm-su-subject m))
  85   )
  86
  87 (or (fboundp 'tm:vm-su-full-name)
  88     (fset 'tm:vm-su-full-name (symbol-function 'vm-su-full-name))
  89     )
  90 (defun vm-su-full-name (m)
  91   (mime-eword/decode-string (tm:vm-su-full-name m))
  92   )
  93
  94 (or (fboundp 'tm:vm-su-to-names)
  95     (fset 'tm:vm-su-to-names (symbol-function 'vm-su-to-names))
  96     )
  97 (defun vm-su-to-names (m)
  98   (mime-eword/decode-string (tm:vm-su-to-names m))
  99   )
 100 ;;;
 101 ))
 102
 103 (defun tm-vm/decode-message-header (&optional count)
 104   "Decode MIME header of current message.
 105 Numeric prefix argument COUNT means to decode the current message plus
 106 the next COUNT-1 messages.  A negative COUNT means decode the current
 107 message and the previous COUNT-1 messages.
 108 When invoked on marked messages (via vm-next-command-uses-marks),
 109 all marked messages are affected, other messages are ignored."
 110   (interactive "p")
 111   (or count (setq count 1))
 112   (vm-follow-summary-cursor)
 113   (vm-select-folder-buffer)
 114   (vm-check-for-killed-summary)
 115   (vm-error-if-folder-empty)
 116   (vm-error-if-folder-read-only)
 117   (let ((mlist (vm-select-marked-or-prefixed-messages count))
 118         (realm nil)
 119         (vlist nil)
 120         (vbufs nil))
 121     (save-excursion
 122       (while mlist
 123         (setq realm (vm-real-message-of (car mlist)))
 124         ;; Go to real folder of this message.
 125         ;; But maybe this message is already real message...
 126         (set-buffer (vm-buffer-of realm))
 127         (let ((buffer-read-only nil))
 128           (vm-save-restriction
 129            (narrow-to-region (vm-headers-of realm) (vm-text-of realm))
 130            (mime/decode-message-header))
 131           (let ((vm-message-pointer (list realm))
 132                 (last-command nil))
 133             (vm-discard-cached-data))
 134           ;; Mark each virtual and real message for later summary
 135           ;; update.
 136           (setq vlist (cons realm (vm-virtual-messages-of realm)))
 137           (while vlist
 138             (vm-mark-for-summary-update (car vlist))
 139             ;; Remember virtual and real folders related this message,
 140             ;; for later display update.
 141             (or (memq (vm-buffer-of (car vlist)) vbufs)
 142                 (setq vbufs (cons (vm-buffer-of (car vlist)) vbufs)))
 143             (setq vlist (cdr vlist)))
 144           (if (eq vm-flush-interval t)
 145               (vm-stuff-virtual-attributes realm)
 146             (vm-set-modflag-of realm t)))
 147         (setq mlist (cdr mlist)))
 148       ;; Update mail-buffers and summaries.
 149       (while vbufs
 150         (set-buffer (car vbufs))
 151         (vm-preview-current-message)
 152         (setq vbufs (cdr vbufs))))))
 153
 154 \f
 155 ;;; @ automatic MIME preview
 156 ;;;
 157
 158 (defvar tm-vm/automatic-mime-preview t
 159   "*If non-nil, show MIME processed article.")
 160
 161 (defvar tm-vm/strict-mime t
 162   "*If nil, do MIME processing even if there is not MIME-Version field.")
 163
 164 (defvar tm-vm/select-message-hook nil
 165   "*List of functions called every time a message is selected.
 166 tm-vm uses `vm-select-message-hook', use this hook instead.")
 167
 168 (defvar tm-vm/system-state nil)
 169 (defun tm-vm/system-state ()
 170   (save-excursion
 171     (if mime::preview/article-buffer
 172         (set-buffer mime::preview/article-buffer)
 173       (vm-select-folder-buffer))
 174     tm-vm/system-state))
 175
 176 (defun tm-vm/display-preview-buffer ()
 177   (let* ((mbuf (current-buffer))
 178          (mwin (vm-get-visible-buffer-window mbuf))
 179          (pbuf (and mime::article/preview-buffer
 180                     (get-buffer mime::article/preview-buffer)))
 181          (pwin (and pbuf (vm-get-visible-buffer-window pbuf))))
 182     (if (and pbuf (tm-vm/system-state))
 183         ;; display preview buffer
 184         (cond
 185          ((and mwin pwin)
 186           (vm-undisplay-buffer mbuf)
 187           (tm-vm/show-current-message))
 188          ((and mwin (not pwin))
 189           (set-window-buffer mwin pbuf)
 190           (tm-vm/show-current-message))
 191          (pwin
 192           (tm-vm/show-current-message))
 193          (t
 194           ;; don't display if neither mwin nor pwin was displayed before.
 195           ))
 196       ;; display folder buffer
 197       (cond
 198        ((and mwin pwin)
 199         (vm-undisplay-buffer pbuf))
 200        ((and (not mwin) pwin)
 201         (set-window-buffer pwin mbuf))
 202        (mwin
 203         ;; folder buffer is already displayed.
 204         )
 205        (t
 206         ;; don't display if neither mwin nor pwin was displayed before.
 207         )))
 208     (set-buffer mbuf)))
 209
 210 (defun tm-vm/preview-current-message ()
 211   ;; assumed current buffer is folder buffer.
 212   (setq tm-vm/system-state nil)
 213   (if (get-buffer mime/output-buffer-name)
 214       (vm-undisplay-buffer mime/output-buffer-name))
 215   (if (and vm-message-pointer tm-vm/automatic-mime-preview)
 216       (if (or (not tm-vm/strict-mime)
 217               (vm-get-header-contents (car vm-message-pointer)
 218                                       "MIME-Version:"))
 219           ;; do MIME processiong.
 220           (progn
 221             (set (make-local-variable 'tm-vm/system-state) 'previewing)
 222             (save-window-excursion
 223               (vm-widen-page)
 224               (goto-char (point-max))
 225               (widen)
 226               (narrow-to-region (point)
 227                                 (save-excursion
 228                                   (goto-char
 229                                    (vm-start-of (car vm-message-pointer))
 230                                    )
 231                                   (forward-line)
 232                                   (point)
 233                                   ))
 234               (mime/viewer-mode)
 235               (if (and tm-vm/use-original-url-button
 236                        vm-use-menus (vm-menu-support-possible-p))
 237                   (vm-energize-urls))
 238               ;; 1996/2/16, fixed by
 239               ;;    Oscar Figueiredo <figueire@lspsun2.epfl.ch>
 240               ;; Highlight message (and display XFace if supported)
 241               (if (or vm-highlighted-header-regexp
 242                       (and (vm-xemacs-p) vm-use-lucid-highlighting))
 243                   (vm-highlight-headers))
 244               (if (and vm-use-menus (vm-menu-support-possible-p))
 245                   (vm-energize-headers))              ;;
 246               (goto-char (point-min))
 247               (narrow-to-region (point) (search-forward "\n\n" nil t))
 248               ))
 249         ;; don't do MIME processing. decode header only.
 250         (let (buffer-read-only)
 251           (mime/decode-message-header))
 252         )
 253     ;; don't preview; do nothing.
 254     )
 255   (tm-vm/display-preview-buffer)
 256   (run-hooks 'tm-vm/select-message-hook))
 257
 258 (defun tm-vm/show-current-message ()
 259   (if mime::preview/article-buffer
 260       (set-buffer mime::preview/article-buffer)
 261     (vm-select-folder-buffer))
 262   ;; Now current buffer is folder buffer.
 263   (if (or t ; mime/viewer-mode doesn't support narrowing yet.
 264           (null vm-preview-lines)
 265           (and (not vm-preview-read-messages)
 266                (not (vm-new-flag
 267                      (car vm-message-pointer)))
 268                (not (vm-unread-flag
 269                      (car vm-message-pointer)))))
 270       (save-excursion
 271         (set-buffer mime::article/preview-buffer)
 272         (save-excursion
 273           (save-excursion
 274             (goto-char (point-min))
 275             (widen))
 276           ;; narrow to page; mime/viewer-mode doesn't support narrowing yet.
 277           )))
 278   (if (vm-get-visible-buffer-window mime::article/preview-buffer)
 279       (progn
 280         (setq tm-vm/system-state 'reading)
 281         (if (vm-new-flag (car vm-message-pointer))
 282             (vm-set-new-flag (car vm-message-pointer) nil))
 283         (if (vm-unread-flag (car vm-message-pointer))
 284             (vm-set-unread-flag (car vm-message-pointer) nil))
 285         (vm-update-summary-and-mode-line)
 286         (tm-vm/howl-if-eom))
 287     (vm-update-summary-and-mode-line)))
 288
 289 (defun tm-vm/toggle-preview-mode ()
 290   (interactive)
 291   (vm-select-folder-buffer)
 292   (vm-display (current-buffer) t (list this-command)
 293               (list this-command 'reading-message))
 294   (if tm-vm/automatic-mime-preview
 295       (setq tm-vm/automatic-mime-preview nil
 296             tm-vm/system-state nil)
 297     (setq tm-vm/automatic-mime-preview t
 298           tm-vm/system-state nil)
 299     (save-restriction
 300        (vm-widen-page)
 301        (let* ((mp (car vm-message-pointer))
 302               (exposed (= (point-min) (vm-start-of mp))))
 303          (if (or (not tm-vm/strict-mime)
 304                  (vm-get-header-contents mp "MIME-Version:"))
 305              ;; do MIME processiong.
 306              (progn
 307                (set (make-local-variable 'tm-vm/system-state) 'previewing)
 308                (save-window-excursion
 309                  (mime/viewer-mode)
 310                  (goto-char (point-min))
 311                  (narrow-to-region (point)
 312                                    (search-forward "\n\n" nil t))
 313                  ))
 314            ;; don't do MIME processing. decode header only.
 315            (let (buffer-read-only)
 316              (mime/decode-message-header))
 317            )
 318          ;; don't preview; do nothing.
 319          ))
 320     (tm-vm/display-preview-buffer)
 321     ))
 322
 323 (add-hook 'vm-select-message-hook 'tm-vm/preview-current-message)
 324 (add-hook 'vm-visit-folder-hook   'tm-vm/preview-current-message)
 325 \f
 326 ;;; tm-vm move commands
 327 ;;;
 328
 329 (defmacro tm-vm/save-window-excursion (&rest forms)
 330   (list 'let '((tm-vm/selected-window (selected-window)))
 331         (list 'unwind-protect
 332               (cons 'progn forms)
 333               '(if (window-live-p tm-vm/selected-window)
 334                    (select-window tm-vm/selected-window)))))
 335
 336 ;;; based on vm-scroll-forward [vm-page.el]
 337 (defun tm-vm/scroll-forward (&optional arg)
 338   (interactive "P")
 339   (let ((this-command 'vm-scroll-forward))
 340     (if (not (tm-vm/system-state))
 341         (vm-scroll-forward arg)
 342       (let* ((mp-changed (vm-follow-summary-cursor))
 343              (mbuf (or (vm-select-folder-buffer) (current-buffer)))
 344              (mwin (vm-get-buffer-window mbuf))
 345              (pbuf (and mime::article/preview-buffer
 346                         (get-buffer mime::article/preview-buffer)))
 347              (pwin (and pbuf (vm-get-buffer-window pbuf)))
 348              (was-invisible (and (null mwin) (null pwin)))
 349              )
 350         ;; now current buffer is folder buffer.
 351         (tm-vm/save-window-excursion
 352          (if (or mp-changed was-invisible)
 353              (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
 354                          (list this-command 'reading-message)))
 355          (tm-vm/display-preview-buffer)
 356          (setq mwin (vm-get-buffer-window mbuf)
 357                pwin (and pbuf (vm-get-buffer-window pbuf)))
 358          (cond
 359           ((or mp-changed was-invisible)
 360            nil
 361            )
 362           ((null pbuf)
 363            ;; preview buffer is killed.
 364            (tm-vm/preview-current-message)
 365            (vm-update-summary-and-mode-line))
 366           ((eq (tm-vm/system-state) 'previewing)
 367            (tm-vm/show-current-message))
 368           (t
 369            (select-window pwin)
 370            (set-buffer pbuf)
 371            (if (pos-visible-in-window-p (point-max) pwin)
 372                (tm-vm/next-message)
 373              ;; not end of message. scroll preview buffer only.
 374              (scroll-up)
 375              (tm-vm/howl-if-eom)
 376              (set-buffer mbuf))
 377            ))))
 378       )))
 379
 380 ;;; based on vm-scroll-backward [vm-page.el]
 381 (defun tm-vm/scroll-backward (&optional arg)
 382   (interactive "P")
 383   (let ((this-command 'vm-scroll-backward))
 384     (if (not (tm-vm/system-state))
 385         (vm-scroll-backward arg)
 386       (let* ((mp-changed (vm-follow-summary-cursor))
 387              (mbuf (or (vm-select-folder-buffer) (current-buffer)))
 388              (mwin (vm-get-buffer-window mbuf))
 389              (pbuf (and mime::article/preview-buffer
 390                         (get-buffer mime::article/preview-buffer)))
 391              (pwin (and pbuf (vm-get-buffer-window pbuf)))
 392              (was-invisible (and (null mwin) (null pwin)))
 393              )
 394         ;; now current buffer is folder buffer.
 395         (if (or mp-changed was-invisible)
 396             (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
 397                         (list this-command 'reading-message)))
 398         (tm-vm/save-window-excursion
 399          (tm-vm/display-preview-buffer)
 400          (setq mwin (vm-get-buffer-window mbuf)
 401                pwin (and pbuf (vm-get-buffer-window pbuf)))
 402          (cond
 403           (was-invisible
 404            nil
 405            )
 406           ((null pbuf)
 407            ;; preview buffer is killed.
 408            (tm-vm/preview-current-message)
 409            (vm-update-summary-and-mode-line))
 410           ((eq (tm-vm/system-state) 'previewing)
 411            (tm-vm/show-current-message))
 412           (t
 413            (select-window pwin)
 414            (set-buffer pbuf)
 415            (if (pos-visible-in-window-p (point-min) pwin)
 416                nil
 417              ;; scroll preview buffer only.
 418              (scroll-down)
 419              (set-buffer mbuf))
 420            ))))
 421       )))
 422
 423 ;;; based on vm-beginning-of-message [vm-page.el]
 424 (defun tm-vm/beginning-of-message ()
 425   "Moves to the beginning of the current message."
 426   (interactive)
 427   (if (not (tm-vm/system-state))
 428       (progn
 429         (setq this-command 'vm-beginning-of-message)
 430         (vm-beginning-of-message))
 431     (vm-follow-summary-cursor)
 432     (vm-select-folder-buffer)
 433     (vm-check-for-killed-summary)
 434     (vm-error-if-folder-empty)
 435     (let ((mbuf (current-buffer))
 436           (pbuf (and mime::article/preview-buffer
 437                      (get-buffer mime::article/preview-buffer))))
 438       (if (null pbuf)
 439           (progn
 440             (tm-vm/preview-current-message)
 441             (setq pbuf (get-buffer mime::article/preview-buffer))
 442             ))
 443       (vm-display mbuf t '(vm-beginning-of-message)
 444                   '(vm-beginning-of-message reading-message))
 445       (tm-vm/display-preview-buffer)
 446       (set-buffer pbuf)
 447       (tm-vm/save-window-excursion
 448        (select-window (vm-get-buffer-window pbuf))
 449        (push-mark)
 450        (goto-char (point-min))
 451        ))))
 452
 453 ;;; based on vm-end-of-message [vm-page.el]
 454 (defun tm-vm/end-of-message ()
 455   "Moves to the end of the current message."
 456   (interactive)
 457   (if (not (tm-vm/system-state))
 458       (progn
 459         (setq this-command 'vm-end-of-message)
 460         (vm-end-of-message))
 461     (vm-follow-summary-cursor)
 462     (vm-select-folder-buffer)
 463     (vm-check-for-killed-summary)
 464     (vm-error-if-folder-empty)
 465     (let ((mbuf (current-buffer))
 466           (pbuf (and mime::article/preview-buffer
 467                      (get-buffer mime::article/preview-buffer))))
 468       (if (null pbuf)
 469           (progn
 470             (tm-vm/preview-current-message)
 471             (setq pbuf (get-buffer mime::article/preview-buffer))
 472             ))
 473       (vm-display mbuf t '(vm-end-of-message)
 474                   '(vm-end-of-message reading-message))
 475       (tm-vm/display-preview-buffer)
 476       (set-buffer pbuf)
 477       (tm-vm/save-window-excursion
 478        (select-window (vm-get-buffer-window pbuf))
 479        (push-mark)
 480        (goto-char (point-max))
 481        ))))
 482
 483 ;;; based on vm-howl-if-eom [vm-page.el]
 484 (defun tm-vm/howl-if-eom ()
 485   (let* ((pbuf (or mime::article/preview-buffer (current-buffer)))
 486          (pwin (and (vm-get-visible-buffer-window pbuf))))
 487     (and pwin
 488          (save-excursion
 489            (save-window-excursion
 490              (condition-case ()
 491                  (let ((next-screen-context-lines 0))
 492                    (select-window pwin)
 493                    (save-excursion
 494                      (save-window-excursion
 495                        (let ((scroll-in-place-replace-original nil))
 496                          (scroll-up))))
 497                    nil)
 498                (error t))))
 499          (tm-vm/emit-eom-blurb)
 500          )))
 501
 502 ;;; based on vm-emit-eom-blurb [vm-page.el]
 503 (defun tm-vm/emit-eom-blurb ()
 504   (save-excursion
 505     (if mime::preview/article-buffer
 506         (set-buffer mime::preview/article-buffer))
 507     (vm-emit-eom-blurb)))
 508
 509 ;;; based on vm-quit [vm-folder.el]
 510 (defun tm-vm/quit ()
 511   (interactive)
 512   (save-excursion
 513     (vm-select-folder-buffer)
 514     (if (and mime::article/preview-buffer
 515              (get-buffer mime::article/preview-buffer))
 516         (kill-buffer mime::article/preview-buffer)))
 517   (vm-quit))
 518
 519 (substitute-key-definition 'vm-scroll-forward
 520                            'tm-vm/scroll-forward vm-mode-map)
 521 (substitute-key-definition 'vm-scroll-backward
 522                            'tm-vm/scroll-backward vm-mode-map)
 523 (substitute-key-definition 'vm-beginning-of-message
 524                            'tm-vm/beginning-of-message vm-mode-map)
 525 (substitute-key-definition 'vm-end-of-message
 526                            'tm-vm/end-of-message vm-mode-map)
 527 (substitute-key-definition 'vm-quit
 528                            'tm-vm/quit vm-mode-map)
 529
 530 ;;; based on vm-next-message [vm-motion.el]
 531 (defun tm-vm/next-message ()
 532   (set-buffer mime::preview/article-buffer)
 533   (let ((this-command 'vm-next-message)
 534         (owin (selected-window))
 535         (vm-preview-lines nil)
 536         )
 537     (vm-next-message 1 nil t)
 538     (if (window-live-p owin)
 539         (select-window owin))))
 540
 541 ;;; based on vm-previous-message [vm-motion.el]
 542 (defun tm-vm/previous-message ()
 543   (set-buffer mime::preview/article-buffer)
 544   (let ((this-command 'vm-previous-message)
 545         (owin (selected-window))
 546         (vm-preview-lines nil)
 547         )
 548     (vm-previous-message 1 nil t)
 549     (if (window-live-p owin)
 550         (select-window owin))))
 551
 552 (set-alist 'mime-viewer/over-to-previous-method-alist
 553            'vm-mode 'tm-vm/previous-message)
 554 (set-alist 'mime-viewer/over-to-next-method-alist
 555            'vm-mode 'tm-vm/next-message)
 556 (set-alist 'mime-viewer/over-to-previous-method-alist
 557            'vm-virtual-mode 'tm-vm/previous-message)
 558 (set-alist 'mime-viewer/over-to-next-method-alist
 559            'vm-virtual-mode 'tm-vm/next-message)
 560
 561 ;;; @@ vm-yank-message
 562 ;;;
 563 ;; 1996/3/28 by Oscar Figueiredo <figueire@lspsun16.epfl.ch>
 564
 565 (require 'vm-reply)
 566
 567 (defvar tm-vm/yank:message-to-restore nil
 568   "For internal use by tm-vm only.")
 569
 570 (defun vm-yank-message (&optional message)
 571   "Yank message number N into the current buffer at point.
 572 When called interactively N is always read from the minibuffer.  When
 573 called non-interactively the first argument is expected to be a
 574 message struct.
 575
 576 This function originally provided by vm-reply has been patched for TM
 577 in order to provide better citation of MIME messages : if a MIME
 578 Preview buffer exists for the message then its contents are inserted
 579 instead of the raw message.
 580
 581 This command is meant to be used in VM created Mail mode buffers; the
 582 yanked message comes from the mail buffer containing the message you
 583 are replying to, forwarding, or invoked VM's mail command from.
 584
 585 All message headers are yanked along with the text.  Point is
 586 left before the inserted text, the mark after.  Any hook
 587 functions bound to mail-citation-hook are run, after inserting
 588 the text and setting point and mark.  For backward compatibility,
 589 if mail-citation-hook is set to nil, `mail-yank-hooks' is run
 590 instead.
 591
 592 If mail-citation-hook and mail-yank-hooks are both nil, this
 593 default action is taken: the yanked headers are trimmed as
 594 specified by vm-included-text-headers and
 595 vm-included-text-discard-header-regexp, and the value of
 596 vm-included-text-prefix is prepended to every yanked line."
 597   (interactive
 598    (list
 599     ;; What we really want for the first argument is a message struct,
 600     ;; but if called interactively, we let the user type in a message
 601     ;; number instead.
 602     (let (mp default
 603              (result 0)
 604              prompt
 605              (last-command last-command)
 606              (this-command this-command))
 607       (if (bufferp vm-mail-buffer)
 608           (save-excursion
 609             (vm-select-folder-buffer)
 610             (setq default (and vm-message-pointer
 611                                (vm-number-of (car vm-message-pointer)))
 612                   prompt (if default
 613                              (format "Yank message number: (default %s) "
 614                                      default)
 615                            "Yank message number: "))
 616             (while (zerop result)
 617               (setq result (read-string prompt))
 618               (and (string= result "") default (setq result default))
 619               (setq result (string-to-int result)))
 620             (if (null (setq mp (nthcdr (1- result) vm-message-list)))
 621                 (error "No such message."))
 622             (setq tm-vm/yank:message-to-restore (string-to-int default))
 623             (save-selected-window
 624               (vm-goto-message result))
 625             (car mp))
 626         nil))))
 627   (if (null message)
 628       (if mail-reply-buffer
 629           (tm-vm/yank-content)
 630         (error "This is not a VM Mail mode buffer."))
 631     (if (null (buffer-name vm-mail-buffer))
 632         (error "The folder buffer containing message %d has been killed."
 633                (vm-number-of message)))
 634     (vm-display nil nil '(vm-yank-message)
 635                 '(vm-yank-message composing-message))
 636     (let ((b (current-buffer)) (start (point)) end)
 637       (save-restriction
 638         (widen)
 639         (save-excursion
 640           (set-buffer (vm-buffer-of message))
 641           (let* ((mbuf (current-buffer))
 642                  (pbuf (and mime::article/preview-buffer
 643                                         ; is there a preview buffer alive ?
 644                             (get-buffer mime::article/preview-buffer)
 645                                         ; rebuild preview to ensure it
 646                                         ; corresponds to the current message
 647                             (save-excursion
 648                               (save-selected-window
 649                                 (save-window-excursion
 650                                   (tm-vm/view-message))))
 651                             (get-buffer mime::article/preview-buffer))))
 652             (if pbuf
 653                 (if running-xemacs
 654                     (let ((tmp (generate-new-buffer "tm-vm/tmp")))
 655                       (set-buffer pbuf)
 656                       (append-to-buffer tmp (point-min) (point-max))
 657                       (set-buffer tmp)
 658                       (map-extents
 659                        '(lambda (ext maparg)
 660                           (set-extent-property ext 'begin-glyph nil)))
 661                       (append-to-buffer b (point-min) (point-max))
 662                       (setq end (vm-marker
 663                                  (+ start (length (buffer-string))) b))
 664                       (kill-buffer tmp))
 665                   (set-buffer pbuf)
 666                   (append-to-buffer b (point-min) (point-max))
 667                   (setq end (vm-marker
 668                              (+ start (length (buffer-string))) b)))
 669               (save-restriction
 670                 (setq message (vm-real-message-of message))
 671                 (set-buffer (vm-buffer-of message))
 672                 (widen)
 673                 (append-to-buffer
 674                  b (vm-headers-of message) (vm-text-end-of message))
 675                 (setq end
 676                       (vm-marker (+ start (- (vm-text-end-of message)
 677                                              (vm-headers-of message))) b))))))
 678         (push-mark end)
 679         (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
 680               (mail-yank-hooks (run-hooks 'mail-yank-hooks))
 681               (t (vm-mail-yank-default message)))
 682         ))
 683     (if tm-vm/yank:message-to-restore
 684         (save-selected-window
 685           (vm-goto-message tm-vm/yank:message-to-restore)
 686           (setq tm-vm/yank:message-to-restore nil)))
 687     ))
 688
 689 \f
 690 ;;; @ for tm-view
 691 ;;;
 692
 693 ;;; based on vm-do-reply [vm-reply.el]
 694 (defun tm-vm/do-reply (buf to-all include-text)
 695   (save-excursion
 696     (set-buffer buf)
 697     (let ((dir default-directory)
 698           to cc subject mp in-reply-to references newsgroups)
 699       (cond ((setq to
 700                    (let ((reply-to (std11-field-body "Reply-To")))
 701                      (if (vm-ignored-reply-to reply-to)
 702                          nil
 703                        reply-to))))
 704             ((setq to (std11-field-body "From")))
 705             ;; (t (error "No From: or Reply-To: header in message"))
 706             )
 707       (if to-all
 708           (setq cc (delq nil (cons cc (std11-field-bodies '("To" "Cc"))))
 709                 cc (mapconcat 'identity cc ","))
 710         )
 711       (setq subject (std11-field-body "Subject"))
 712       (and subject vm-reply-subject-prefix
 713            (let ((case-fold-search t))
 714              (not
 715               (equal
 716                (string-match (regexp-quote vm-reply-subject-prefix)
 717                              subject)
 718                0)))
 719            (setq subject (concat vm-reply-subject-prefix subject)))
 720       (setq in-reply-to (std11-field-body "Message-Id")
 721             references (nconc
 722                         (std11-field-bodies '("References" "In-Reply-To"))
 723                         (list in-reply-to))
 724             newsgroups (list (or (and to-all
 725                                       (std11-field-body "Followup-To"))
 726                                  (std11-field-body "Newsgroups"))))
 727       (setq to (vm-parse-addresses to)
 728             cc (vm-parse-addresses cc))
 729       (if vm-reply-ignored-addresses
 730           (setq to (vm-strip-ignored-addresses to)
 731                 cc (vm-strip-ignored-addresses cc)))
 732       (setq to (vm-delete-duplicates to nil t))
 733       (setq cc (vm-delete-duplicates
 734                 (append (vm-delete-duplicates cc nil t)
 735                         to (copy-sequence to))
 736                 t t))
 737       (and to (setq to (mapconcat 'identity to ",\n ")))
 738       (and cc (setq cc (mapconcat 'identity cc ",\n ")))
 739       (and (null to) (setq to cc cc nil))
 740       (setq references (delq nil references)
 741             references (mapconcat 'identity references " ")
 742             references (vm-parse references "[^<]*\\(<[^>]+>\\)")
 743             references (vm-delete-duplicates references)
 744             references (if references (mapconcat 'identity references "\n\t")))
 745       (setq newsgroups (delq nil newsgroups)
 746             newsgroups (mapconcat 'identity newsgroups ",")
 747             newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
 748             newsgroups (vm-delete-duplicates newsgroups)
 749             newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
 750       (vm-mail-internal
 751        (if to
 752            (format "reply to %s%s"
 753                    (std11-full-name-string
 754                     (car (std11-parse-address-string to)))
 755                    (if cc ", ..." "")))
 756        to subject in-reply-to cc references newsgroups)
 757       (setq mail-reply-buffer buf
 758             ;; vm-system-state 'replying
 759             default-directory dir))
 760     (if include-text
 761         (save-excursion
 762           (goto-char (point-min))
 763           (let ((case-fold-search nil))
 764             (re-search-forward
 765              (concat "^" (regexp-quote mail-header-separator) "$") nil 0))
 766           (forward-char 1)
 767           (tm-vm/yank-content)))
 768     (run-hooks 'vm-reply-hook)
 769     (run-hooks 'vm-mail-mode-hook)
 770     ))
 771
 772 (defun tm-vm/following-method (buf)
 773   (tm-vm/do-reply buf 'to-all 'include-text)
 774   )
 775
 776 (defun tm-vm/yank-content ()
 777   (interactive)
 778   (let ((this-command 'vm-yank-message))
 779     (vm-display nil nil '(vm-yank-message)
 780                 '(vm-yank-message composing-message))
 781     (save-restriction
 782       (narrow-to-region (point)(point))
 783       (insert-buffer mail-reply-buffer)
 784       (goto-char (point-max))
 785       (push-mark)
 786       (goto-char (point-min)))
 787     (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
 788           (mail-yank-hooks (run-hooks 'mail-yank-hooks))
 789           (t (mail-indent-citation)))
 790     ))
 791
 792 (set-alist 'mime-viewer/following-method-alist
 793            'vm-mode
 794            (function tm-vm/following-method))
 795 (set-alist 'mime-viewer/following-method-alist
 796            'vm-virtual-mode
 797            (function tm-vm/following-method))
 798
 799
 800 (defun tm-vm/quit-view-message ()
 801   "Quit MIME-viewer and go back to VM.
 802 This function is called by `mime-viewer/quit' command via
 803 `mime-viewer/quitting-method-alist'."
 804   (if (get-buffer mime/output-buffer-name)
 805       (vm-undisplay-buffer mime/output-buffer-name))
 806   (if (and tm-vm/automatic-mime-preview
 807            (save-excursion
 808              (set-buffer mime::preview/article-buffer)
 809              vm-summary-buffer))
 810       (switch-to-buffer mime::preview/article-buffer)
 811     (mime-viewer/kill-buffer)
 812     (vm-select-folder-buffer)
 813     (setq tm-vm/system-state nil))
 814   (vm-display (current-buffer) t (list this-command)
 815               (list this-command 'reading-message))
 816   (tm-vm/display-preview-buffer)
 817   )
 818
 819 (defun tm-vm/view-message ()
 820   "Decode and view MIME encoded message, under VM."
 821   (interactive)
 822   (vm-follow-summary-cursor)
 823   (vm-select-folder-buffer)
 824   (vm-check-for-killed-summary)
 825   (vm-error-if-folder-empty)
 826   (vm-display (current-buffer) t '(tm-vm/view-message)
 827               '(tm-vm/view-mesage reading-message))
 828   (let* ((mp (car vm-message-pointer))
 829          (ct  (vm-get-header-contents mp "Content-Type:"))
 830          (cte (vm-get-header-contents mp "Content-Transfer-Encoding:"))
 831          (exposed (= (point-min) (vm-start-of mp))))
 832     (save-restriction
 833       (vm-widen-page)
 834       ;; vm-widen-page hides exposed header if pages are delimited.
 835       ;; So, here we expose it again.
 836       (if exposed
 837           (narrow-to-region (vm-start-of mp) (point-max)))
 838       (select-window (vm-get-buffer-window (current-buffer)))
 839       (mime/viewer-mode nil
 840                         (mime/parse-Content-Type (or ct ""))
 841                         cte)
 842       )))
 843
 844 (set-alist 'mime-viewer/quitting-method-alist
 845            'vm-mode
 846            'tm-vm/quit-view-message)
 847
 848 (set-alist 'mime-viewer/quitting-method-alist
 849            'vm-virtual-mode
 850            'tm-vm/quit-view-message)
 851
 852
 853 ;;; @ for tm-partial
 854 ;;;
 855
 856 (call-after-loaded
 857  'tm-partial
 858  (function
 859   (lambda ()
 860     (set-atype 'mime/content-decoding-condition
 861                '((type . "message/partial")
 862                  (method . mime-article/grab-message/partials)
 863                  (major-mode . vm-mode)
 864                  (summary-buffer-exp . vm-summary-buffer)
 865                  ))
 866     (set-alist 'tm-partial/preview-article-method-alist
 867                'vm-mode
 868                (function
 869                 (lambda ()
 870                   (tm-vm/view-message)
 871                   )))
 872     )))
 873
 874
 875 ;;; @ for tm-edit
 876 ;;;
 877
 878 ;;; @@ for multipart/digest
 879 ;;;
 880
 881 (defvar tm-vm/forward-message-hook nil
 882   "*List of functions called after a Mail mode buffer has been
 883 created to forward a message in message/rfc822 type format.
 884 If `vm-forwarding-digest-type' is \"rfc1521\", tm-vm runs this
 885 hook instead of `vm-forward-message-hook'.")
 886
 887 (defvar tm-vm/send-digest-hook nil
 888   "*List of functions called after a Mail mode buffer has been
 889 created to send a digest in multipart/digest type format.
 890 If `vm-digest-send-type' is \"rfc1521\", tm-vm runs this hook
 891 instead of `vm-send-digest-hook'.")
 892
 893 (defun tm-vm/enclose-messages (mlist &optional preamble)
 894   "Enclose the messages in MLIST as multipart/digest.
 895 The resulting digest is inserted at point in the current buffer.
 896
 897 MLIST should be a list of message structs (real or virtual).
 898 These are the messages that will be enclosed."
 899   (if mlist
 900       (let ((digest (consp (cdr mlist)))
 901             (mp mlist)
 902             m)
 903         (save-restriction
 904           (narrow-to-region (point) (point))
 905           (while mlist
 906             (setq m (vm-real-message-of (car mlist)))
 907             (mime-editor/insert-tag "message" "rfc822")
 908             (tm-mail/insert-message m)
 909             (goto-char (point-max))
 910             (setq mlist (cdr mlist)))
 911           (if preamble
 912               (progn
 913                 (goto-char (point-min))
 914                 (mime-editor/insert-tag "text" "plain")
 915                 (vm-unsaved-message "Building digest preamble...")
 916                 (while mp
 917                   (let ((vm-summary-uninteresting-senders nil))
 918                     (insert
 919                      (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n"))
 920                   (if vm-digest-center-preamble
 921                       (progn
 922                         (forward-char -1)
 923                         (center-line)
 924                         (forward-char 1)))
 925                   (setq mp (cdr mp)))))
 926           (if digest
 927               (mime-editor/enclose-digest-region (point-min) (point-max)))
 928           ))))
 929
 930 (defun tm-vm/forward-message ()
 931   "Forward the current message to one or more recipients.
 932 You will be placed in a Mail mode buffer as you would with a
 933 reply, but you must fill in the To: header and perhaps the
 934 Subject: header manually."
 935   (interactive)
 936   (if (not (equal vm-forwarding-digest-type "rfc1521"))
 937       (vm-forward-message)
 938     (vm-follow-summary-cursor)
 939     (vm-select-folder-buffer)
 940     (vm-check-for-killed-summary)
 941     (vm-error-if-folder-empty)
 942     (if (eq last-command 'vm-next-command-uses-marks)
 943         (let ((vm-digest-send-type vm-forwarding-digest-type))
 944           (setq this-command 'vm-next-command-uses-marks)
 945           (command-execute 'tm-vm/send-digest))
 946       (let ((dir default-directory)
 947             (mp vm-message-pointer))
 948         (save-restriction
 949           (widen)
 950           (vm-mail-internal
 951            (format "forward of %s's note re: %s"
 952                    (vm-su-full-name (car vm-message-pointer))
 953                    (vm-su-subject (car vm-message-pointer)))
 954            nil
 955            (and vm-forwarding-subject-format
 956                 (let ((vm-summary-uninteresting-senders nil))
 957                   (vm-sprintf 'vm-forwarding-subject-format (car mp)))))
 958           (make-local-variable 'vm-forward-list)
 959           (setq vm-system-state 'forwarding
 960                 vm-forward-list (list (car mp))
 961                 default-directory dir)
 962           (goto-char (point-min))
 963           (re-search-forward
 964            (concat "^" (regexp-quote mail-header-separator) "\n") nil 0)
 965           (tm-vm/enclose-messages vm-forward-list)
 966           (mail-position-on-field "To"))
 967         (run-hooks 'tm-vm/forward-message-hook)
 968         (run-hooks 'vm-mail-mode-hook)))))
 969
 970 (defun tm-vm/send-digest (&optional arg)
 971   "Send a digest of all messages in the current folder to recipients.
 972 The type of the digest is specified by the variable vm-digest-send-type.
 973 You will be placed in a Mail mode buffer as is usual with replies, but you
 974 must fill in the To: and Subject: headers manually.
 975
 976 If invoked on marked messages (via vm-next-command-uses-marks),
 977 only marked messages will be put into the digest."
 978   (interactive "P")
 979   (if (not (equal vm-digest-send-type "rfc1521"))
 980       (vm-send-digest arg)
 981     (vm-select-folder-buffer)
 982     (vm-check-for-killed-summary)
 983     (vm-error-if-folder-empty)
 984     (let ((dir default-directory)
 985           (vm-forward-list (if (eq last-command 'vm-next-command-uses-marks)
 986                                (vm-select-marked-or-prefixed-messages 0)
 987                              vm-message-list))
 988           start)
 989       (save-restriction
 990         (widen)
 991         (vm-mail-internal (format "digest from %s" (buffer-name)))
 992         (setq vm-system-state 'forwarding
 993               default-directory dir)
 994         (goto-char (point-min))
 995         (re-search-forward (concat "^" (regexp-quote mail-header-separator)
 996                                    "\n"))
 997         (goto-char (match-end 0))
 998         (vm-unsaved-message "Building %s digest..." vm-digest-send-type)
 999         (tm-vm/enclose-messages vm-forward-list arg)
1000         (mail-position-on-field "To")
1001         (message "Building %s digest... done" vm-digest-send-type)))
1002     (run-hooks 'tm-vm/send-digest-hook)
1003     (run-hooks 'vm-mail-mode-hook)))
1004
1005 (substitute-key-definition 'vm-forward-message
1006                            'tm-vm/forward-message vm-mode-map)
1007 (substitute-key-definition 'vm-send-digest
1008                            'tm-vm/send-digest vm-mode-map)
1009 \f
1010
1011 ;;; @@ setting
1012 ;;;
1013
1014 (defvar tm-vm/use-xemacs-popup-menu t)
1015
1016 ;;; modified by Steven L. Baur <steve@miranova.com>
1017 ;;;     1995/12/6 (c.f. [tm-en:209])
1018 (defun mime-editor/attach-to-vm-mode-menu ()
1019   "Arrange to attach MIME editor's popup menu to VM's"
1020   (if (boundp 'vm-menu-mail-menu)
1021       (progn
1022         (setq vm-menu-mail-menu
1023               (append vm-menu-mail-menu
1024                       (list "----"
1025                             mime-editor/popup-menu-for-xemacs)))
1026         (remove-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu)
1027         )))
1028
1029 (call-after-loaded
1030  'tm-edit
1031  (function
1032   (lambda ()
1033     (autoload 'tm-mail/insert-message "tm-mail")
1034     (set-alist 'mime-editor/message-inserter-alist
1035                'mail-mode (function tm-mail/insert-message))
1036     (set-alist 'mime-editor/split-message-sender-alist
1037                'mail-mode (function
1038                            (lambda ()
1039                              (interactive)
1040                              (sendmail-send-it)
1041                              )))
1042     (if (and (string-match "XEmacs\\|Lucid" emacs-version)
1043              tm-vm/use-xemacs-popup-menu)
1044         (add-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu)
1045       )
1046     )))
1047
1048 (call-after-loaded
1049  'mime-setup
1050  (function
1051   (lambda ()
1052     (setq vm-forwarding-digest-type "rfc1521")
1053     (setq vm-digest-send-type "rfc1521")
1054     )))
1055
1056
1057 ;;; @ for BBDB
1058 ;;;
1059
1060 (call-after-loaded
1061  'bbdb
1062  (function
1063   (lambda ()
1064     (require 'bbdb-vm)
1065     (require 'tm-bbdb)
1066     (or (fboundp 'tm:bbdb/vm-update-record)
1067         (fset 'tm:bbdb/vm-update-record
1068               (symbol-function 'bbdb/vm-update-record)))
1069     (defun bbdb/vm-update-record (&optional offer-to-create)
1070       (vm-select-folder-buffer)
1071       (if (and (tm-vm/system-state)
1072                mime::article/preview-buffer
1073                (get-buffer mime::article/preview-buffer))
1074           (tm-bbdb/update-record offer-to-create)
1075         (tm:bbdb/vm-update-record offer-to-create)
1076         ))
1077     (remove-hook 'vm-select-message-hook 'bbdb/vm-update-record)
1078     (remove-hook 'vm-show-message-hook 'bbdb/vm-update-record)
1079     (add-hook 'tm-vm/select-message-hook 'bbdb/vm-update-record)
1080     )))
1081
1082
1083 ;;; @ end
1084 ;;;
1085
1086 (provide 'tm-vm)
1087
1088 (run-hooks 'tm-vm-load-hook)
1089
1090 ;;; tm-vm.el ends here.