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