cgit.sxemacs.org Git - packages/blob - xemacs-packages/tm/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 <Oscar.Figueiredo@di.epfl.ch>
  10 ;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
  11 ;; Created: 1994/10/29
  12 ;; Version: $Revision: 1.3 $
  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 GNU Emacs; see the file COPYING.  If not, write to the
  29 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  30 ;; Boston, MA 02111-1307, USA.
  31
  32 ;;; Commentary:
  33
  34 ;;      Please insert `(require 'tm-vm)' in your ~/.vm file.
  35
  36 ;;; Code:
  37
  38 (eval-when-compile
  39   (require 'tm-mail)
  40   (require 'vm)
  41   (require 'vm-window)
  42   (require 'vm-macro))
  43
  44 (require 'tm-edit)
  45 (require 'tm-view)
  46 (require 'vm-reply)
  47 (require 'vm-summary)
  48 (require 'vm-menu)
  49 (require 'vm-toolbar)
  50 (require 'vm-mime)
  51
  52 ;;; @ Variables
  53
  54 ;;; @@ User customization variables
  55
  56 (defvar tm-vm/use-vm-bindings t
  57   "*If t, use VM compatible keybindings in MIME Preview buffers.
  58 Otherwise TM generic bindings for content extraction/playing are
  59 made available.")
  60
  61 (defvar tm-vm/attach-to-popup-menus t
  62   "*If t append MIME specific commands to VM's popup menus.")
  63
  64 (defvar tm-vm/use-original-url-button t
  65   "*If it is t, use original URL button instead of tm's.")
  66
  67 (defvar tm-vm/automatic-mime-preview (or (and (boundp 'vm-display-using-mime)
  68                                               vm-display-using-mime)
  69                                          t)
  70   "*If non-nil, automatically process and show MIME messages.")
  71
  72 (defvar tm-vm/strict-mime t
  73   "*If nil, do MIME processing even if there is no MIME-Version field.")
  74
  75 (defvar tm-vm/use-ps-print (not (featurep 'mule))
  76   "*Use Postscript printing (ps-print) to print MIME messages.")
  77
  78 (defvar tm-vm-load-hook nil
  79   "*List of functions called after tm-vm is loaded.")
  80
  81 (defvar tm-vm/select-message-hook nil
  82   "*List of functions called every time a message is selected.
  83 tm-vm uses `vm-select-message-hook', use tm-vm/select-message-hook instead.
  84 When the hooks are run current buffer is either VM folder buffer with
  85 the current message delimited by (point-min) and (point-max) or the MIME
  86 Preview buffer.")
  87
  88 (defvar tm-vm/forward-message-hook vm-forward-message-hook
  89   "*List of functions called after a Mail mode buffer has been
  90 created to forward a message in message/rfc822 type format.
  91 If `vm-forwarding-digest-type' is \"rfc1521\", tm-vm runs this
  92 hook instead of `vm-forward-message-hook'.")
  93
  94 (defvar tm-vm/send-digest-hook nil
  95   "*List of functions called after a Mail mode buffer has been
  96 created to send a digest in multipart/digest type format.
  97 If `vm-digest-send-type' is \"rfc1521\", tm-vm runs this hook
  98 instead of `vm-send-digest-hook'.")
  99
 100 (defvar tm-vm/build-mime-preview-buffer-hook nil
 101   "*List of functions called each time a MIME Preview buffer is built.
 102 These hooks are run in the MIME-Preview buffer.")
 103
 104 ;;; @@ System/Information variables
 105
 106 (defconst tm-vm/RCS-ID
 107   "$Id: tm-vm.el,v 1.3 2008-04-24 20:33:12 stephent Exp $")
 108 (defconst tm-vm/version (get-version-string tm-vm/RCS-ID))
 109
 110 ; Ensure vm-menu-mail-menu gets properly defined *before* tm-vm/vm-emulation-map
 111 ; since it contains a call to vm-menu-initialize-vm-mode-menu-map
 112 (setq vm-menu-mail-menu
 113   (let ((title (if (vm-menu-fsfemacs-menus-p)
 114                    (list "Mail Commands"
 115                          "Mail Commands"
 116                          "---"
 117                          "---")
 118                  (list "Mail Commands"))))
 119     (append
 120      title
 121      (list ["Send and Exit" vm-mail-send-and-exit (vm-menu-can-send-mail-p)]
 122            ["Send, Keep Composing" vm-mail-send (vm-menu-can-send-mail-p)]
 123            ["Cancel" kill-buffer t]
 124            "----"
 125            "Go to Field:"
 126            "----"
 127            ["      To:" mail-to t]
 128            ["      Subject:" mail-subject       t]
 129            ["      CC:" mail-cc t]
 130            ["      BCC:" mail-bcc t]
 131            ["      Reply-To:" mail-reply-to t]
 132            ["      Text" mail-text t]
 133            "----"
 134            ["Yank Original" vm-menu-yank-original vm-reply-list]
 135            ["Fill Yanked Message" mail-fill-yanked-message t]
 136            ["Insert Signature"  mail-signature t]
 137            ["Insert File..." insert-file t]
 138            ["Insert Buffer..."  insert-buffer t])
 139      (if tm-vm/attach-to-popup-menus
 140          (list "----"
 141                (cons "MIME Commands"
 142                      (mapcar (function (lambda (item)
 143                                          (vector (nth 1 item)
 144                                                  (nth 2 item)
 145                                                  t)))
 146                              mime-editor/menu-list))))
 147      )))
 148
 149 (defvar tm-vm/vm-emulation-map
 150   (let ((map (make-sparse-keymap)))
 151     (define-key map "h" 'vm-summarize)
 152     ;(define-key map "\M-n" 'vm-next-unread-message)
 153     ;(define-key map "\M-p" 'vm-previous-unread-message)
 154     (define-key map "n" 'vm-next-message)
 155     (define-key map "p" 'vm-previous-message)
 156     (define-key map "N" 'vm-next-message-no-skip)
 157     (define-key map "P" 'vm-previous-message-no-skip)
 158     ;(define-key map "\C-\M-n" 'vm-move-message-forward)
 159     ;(define-key map "\C-\M-p" 'vm-move-message-backward)
 160     ;(define-key map "\t" 'vm-goto-message-last-seen)
 161     ;(define-key map "\r" 'vm-goto-message)
 162     (define-key map "^" 'vm-goto-parent-message)
 163     (define-key map "t" 'vm-expose-hidden-headers)
 164     (define-key map " " 'vm-scroll-forward)
 165     (define-key map "b" 'vm-scroll-backward)
 166     (define-key map "\C-?" 'vm-scroll-backward)
 167     (define-key map "d" 'vm-delete-message)
 168     (define-key map "\C-d" 'vm-delete-message-backward)
 169     (define-key map "u" 'vm-undelete-message)
 170     (define-key map "U" 'vm-unread-message)
 171     (define-key map "e" 'vm-edit-message)
 172     ;(define-key map "a" 'vm-set-message-attributes)
 173     ;(define-key map "j" 'vm-discard-cached-data)
 174     ;(define-key map "k" 'vm-kill-subject)
 175     (define-key map "f" 'vm-followup)
 176     (define-key map "F" 'vm-followup-include-text)
 177     (define-key map "r" 'vm-reply)
 178     (define-key map "R" 'vm-reply-include-text)
 179     (define-key map "\M-r" 'vm-resend-bounced-message)
 180     (define-key map "B" 'vm-resend-message)
 181     (define-key map "z" 'vm-forward-message)
 182     ;(define-key map "c" 'vm-continue-composing-message)
 183     (define-key map "@" 'vm-send-digest)
 184     ;(define-key map "*" 'vm-burst-digest)
 185     (define-key map "m" 'vm-mail)
 186     (define-key map "g" 'vm-get-new-mail)
 187     ;(define-key map "G" 'vm-sort-messages)
 188     (define-key map "v" 'vm-visit-folder)
 189     (define-key map "s" 'vm-save-message)
 190     ;(define-key map "w" 'vm-save-message-sans-headers)
 191     ;(define-key map "A" 'vm-auto-archive-messages)
 192     (define-key map "S" 'vm-save-folder)
 193     ;(define-key map "|" 'vm-pipe-message-to-command)
 194     (define-key map "#" 'vm-expunge-folder)
 195     (define-key map "q" 'vm-quit)
 196     (define-key map "x" 'vm-quit-no-change)
 197     (define-key map "i" 'vm-iconify-frame)
 198     (define-key map "?" 'vm-help)
 199     (define-key map "\C-_" 'vm-undo)
 200     (define-key map "\C-xu" 'vm-undo)
 201     (define-key map "!" 'shell-command)
 202     (define-key map "<" 'vm-beginning-of-message)
 203     (define-key map ">" 'vm-end-of-message)
 204     ;(define-key map "\M-s" 'vm-isearch-forward)
 205     (define-key map "=" 'vm-summarize)
 206     (define-key map "L" 'vm-load-init-file)
 207     ;(define-key map "l" (make-sparse-keymap))
 208     ;(define-key map "la" 'vm-add-message-labels)
 209     ;(define-key map "ld" 'vm-delete-message-labels)
 210     ;(define-key map "V" (make-sparse-keymap))
 211     ;(define-key map "VV" 'vm-visit-virtual-folder)
 212     ;(define-key map "VC" 'vm-create-virtual-folder)
 213     ;(define-key map "VA" 'vm-apply-virtual-folder)
 214     ;(define-key map "VM" 'vm-toggle-virtual-mirror)
 215     ;(define-key map "V?" 'vm-virtual-help)
 216     ;(define-key map "M" (make-sparse-keymap))
 217     ;(define-key map "MN" 'vm-next-command-uses-marks)
 218     ;(define-key map "Mn" 'vm-next-command-uses-marks)
 219     ;(define-key map "MM" 'vm-mark-message)
 220     ;(define-key map "MU" 'vm-unmark-message)
 221     ;(define-key map "Mm" 'vm-mark-all-messages)
 222     ;(define-key map "Mu" 'vm-clear-all-marks)
 223     ;(define-key map "MC" 'vm-mark-matching-messages)
 224     ;(define-key map "Mc" 'vm-unmark-matching-messages)
 225     ;(define-key map "MT" 'vm-mark-thread-subtree)
 226     ;(define-key map "Mt" 'vm-unmark-thread-subtree)
 227     ;(define-key map "MS" 'vm-mark-messages-same-subject)
 228     ;(define-key map "Ms" 'vm-unmark-messages-same-subject)
 229     ;(define-key map "MA" 'vm-mark-messages-same-author)
 230     ;(define-key map "Ma" 'vm-unmark-messages-same-author)
 231     ;(define-key map "M?" 'vm-mark-help)
 232     ;(define-key map "W" (make-sparse-keymap))
 233     ;(define-key map "WW" 'vm-apply-window-configuration)
 234     ;(define-key map "WS" 'vm-save-window-configuration)
 235     ;(define-key map "WD" 'vm-delete-window-configuration)
 236     ;(define-key map "W?" 'vm-window-help)
 237     (define-key map "\C-t" 'vm-toggle-threads-display)
 238     (define-key map "\C-x\C-s" 'vm-save-buffer)
 239     (define-key map "\C-x\C-w" 'vm-write-file)
 240     (define-key map "\C-x\C-q" 'vm-toggle-read-only)
 241     ;(define-key map "%" 'vm-change-folder-type)
 242     (define-key map "\M-C" 'vm-show-copying-restrictions)
 243     (define-key map "\M-W" 'vm-show-no-warranty)
 244     ;; suppress-keymap provides these, but now that we don't use
 245     ;; suppress-keymap anymore...
 246     (define-key map "0" 'digit-argument)
 247     (define-key map "1" 'digit-argument)
 248     (define-key map "2" 'digit-argument)
 249     (define-key map "3" 'digit-argument)
 250     (define-key map "4" 'digit-argument)
 251     (define-key map "5" 'digit-argument)
 252     (define-key map "6" 'digit-argument)
 253     (define-key map "7" 'digit-argument)
 254     (define-key map "8" 'digit-argument)
 255     (define-key map "9" 'digit-argument)
 256     (define-key map "-" 'negative-argument)
 257     (if mouse-button-2
 258         (define-key map mouse-button-2 (function tm:button-dispatcher)))
 259     (if (vm-menu-fsfemacs-menus-p)
 260         (progn
 261           (vm-menu-initialize-vm-mode-menu-map)
 262           (define-key map [menu-bar]
 263             (lookup-key vm-mode-menu-map [rootmenu vm]))))
 264     map)
 265   "VM emulation keymap for MIME-Preview buffers.")
 266
 267 (defvar tm-vm/popup-menu
 268   (let (fsfmenu
 269         (dummy (make-sparse-keymap))
 270         (menu (append vm-menu-dispose-menu
 271                       (list "----"
 272                             (cons mime-viewer/menu-title
 273                                   (mapcar (function
 274                                            (lambda (item)
 275                                              (vector (nth 1 item)(nth 2 item) t)))
 276                                           mime-viewer/menu-list))))))
 277     (if running-xemacs
 278         menu
 279       (vm-easy-menu-define fsfmenu (list dummy) nil menu)
 280       fsfmenu))
 281   "VM's popup menu + MIME specific commands")
 282
 283
 284
 285 (define-key vm-mode-map "Z" 'tm-vm/view-message)
 286 (define-key vm-mode-map "T" 'tm-vm/decode-message-header)
 287 (define-key vm-mode-map "\et" 'tm-vm/toggle-preview-mode)
 288
 289 ; Disable VM 6 built-in MIME handling
 290 (setq vm-display-using-mime nil
 291       vm-send-using-mime nil)
 292
 293 ;;; @ MIME encoded-words
 294
 295 (defvar tm-vm/use-tm-patch nil
 296   "Does not decode encoded-words in summary buffer if it is t.
 297 If you use tiny-mime patch for VM (by RIKITAKE Kenji
 298 <kenji@reseau.toyonaka.osaka.jp>), please set it t [tm-vm.el]")
 299
 300 (or tm-vm/use-tm-patch
 301     (progn
 302 (defadvice vm-compile-format (around tm activate)
 303   "MIME decoding support through TM added."
 304   (let ((vm-display-using-mime t))
 305     ad-do-it))
 306
 307 (defadvice vm-tokenized-summary-insert (around tm activate)
 308   "MIME decoding support through TM added."
 309   (let ((vm-display-using-mime t))
 310     ad-do-it))
 311
 312 (fset 'vm-decode-mime-encoded-words-in-string 'mime-eword/decode-string)
 313 (fset 'vm-reencode-mime-encoded-words-in-string 'mime-eword/encode-string)
 314
 315 ))
 316
 317 (defun tm-vm/decode-message-header (&optional count)
 318   "Decode MIME header of current message.
 319 Numeric prefix argument COUNT means to decode the current message plus
 320 the next COUNT-1 messages.  A negative COUNT means decode the current
 321 message and the previous COUNT-1 messages.
 322 When invoked on marked messages (via vm-next-command-uses-marks),
 323 all marked messages are affected, other messages are ignored."
 324   (interactive "p")
 325   (or count (setq count 1))
 326   (vm-follow-summary-cursor)
 327   (vm-select-folder-buffer)
 328   (vm-check-for-killed-summary)
 329   (vm-error-if-folder-empty)
 330   (vm-error-if-folder-read-only)
 331   (let ((mlist (vm-select-marked-or-prefixed-messages count))
 332         (realm nil)
 333         (vlist nil)
 334         (vbufs nil))
 335     (save-excursion
 336       (while mlist
 337         (setq realm (vm-real-message-of (car mlist)))
 338         ;; Go to real folder of this message.
 339         ;; But maybe this message is already real message...
 340         (set-buffer (vm-buffer-of realm))
 341         (let ((buffer-read-only nil))
 342           (vm-save-restriction
 343            (narrow-to-region (vm-headers-of realm) (vm-text-of realm))
 344            (mime/decode-message-header))
 345           (let ((vm-message-pointer (list realm))
 346                 (last-command nil))
 347             (vm-discard-cached-data))
 348           ;; Mark each virtual and real message for later summary
 349           ;; update.
 350           (setq vlist (cons realm (vm-virtual-messages-of realm)))
 351           (while vlist
 352             (vm-mark-for-summary-update (car vlist))
 353             ;; Remember virtual and real folders related this message,
 354             ;; for later display update.
 355             (or (memq (vm-buffer-of (car vlist)) vbufs)
 356                 (setq vbufs (cons (vm-buffer-of (car vlist)) vbufs)))
 357             (setq vlist (cdr vlist)))
 358           (if (eq vm-flush-interval t)
 359               (vm-stuff-virtual-attributes realm)
 360             (vm-set-modflag-of realm t)))
 361         (setq mlist (cdr mlist)))
 362       ;; Update mail-buffers and summaries.
 363       (while vbufs
 364         (set-buffer (car vbufs))
 365         (vm-preview-current-message)
 366         (setq vbufs (cdr vbufs))))))
 367
 368 (defun tm-vm/header-filter ()
 369   "Filter headers in current buffer according to vm-visible-headers and vm-invisible-header-regexp.
 370 Current buffer is assumed to have a message-like structure."
 371   (goto-char (point-min))
 372   (let ((visible-headers vm-visible-headers))
 373     (if (or vm-use-lucid-highlighting
 374             vm-display-xfaces)
 375         (setq visible-headers (cons "X-Face:" vm-visible-headers)))
 376     (vm-reorder-message-headers nil
 377                                 visible-headers
 378                                 vm-invisible-header-regexp)
 379     (mime/decode-message-header)))
 380
 381 (setq mime-viewer/content-header-filter-alist
 382       (append '((vm-mode . tm-vm/header-filter)
 383                 (vm-virtual-mode . tm-vm/header-filter))
 384               mime-viewer/content-header-filter-alist))
 385
 386 \f
 387
 388 ;;; @ MIME Viewer
 389
 390 (setq mime-viewer/code-converter-alist
 391       (append
 392        (list (cons 'vm-mode 'mime-charset/decode-buffer)
 393              (cons 'vm-virtual-mode 'mime-charset/decode-buffer))
 394        mime-viewer/code-converter-alist))
 395
 396 ;;; @@ MIME-Preview buffer management
 397
 398 (defvar tm-vm/system-state nil)
 399
 400 (defun tm-vm/system-state ()
 401   (save-excursion
 402     (if mime::preview/article-buffer
 403         (set-buffer mime::preview/article-buffer)
 404       (vm-select-folder-buffer))
 405     tm-vm/system-state))
 406
 407 (defun tm-vm/build-preview-buffer ()
 408   "Build the MIME Preview buffer for the current VM message.
 409 Current buffer should be VM's folder buffer."
 410
 411   (set (make-local-variable 'tm-vm/system-state) 'mime-viewing)
 412   (setq vm-system-state 'reading)
 413
 414   ;; Update message flags and store them in folder buffer before
 415   ;; entering MIME viewer
 416   (tm-vm/update-message-status)
 417
 418   ;; We need to save window configuration because we may be working
 419   ;; in summary window
 420   (save-window-excursion
 421     (save-restriction
 422       (save-excursion
 423         (widen)
 424         (goto-char (vm-start-of (car vm-message-pointer)))
 425         (forward-line)
 426         (narrow-to-region (point)
 427                           (vm-end-of (car vm-message-pointer)))
 428
 429         (let ((ml vm-message-list)
 430               (mp vm-message-pointer))
 431           (mime/viewer-mode nil nil nil nil nil nil)
 432           (setq vm-mail-buffer mime::preview/article-buffer)
 433           (setq vm-message-list ml
 434                 vm-message-pointer mp))
 435         ;; Install VM toolbar for MIME-Preview buffer if not installed
 436         (tm-vm/check-for-toolbar)
 437         (if tm-vm/use-vm-bindings
 438             (progn
 439               (define-key tm-vm/vm-emulation-map "\C-c" (current-local-map))
 440               (use-local-map tm-vm/vm-emulation-map)
 441               (vm-menu-install-menubar)
 442               (if (and vm-use-menus
 443                        (vm-menu-support-possible-p))
 444                   (setq mode-popup-menu tm-vm/popup-menu))))
 445
 446         ;; Highlight message (and display XFace if supported)
 447         (if (or vm-highlighted-header-regexp
 448                 (and running-xemacs vm-use-lucid-highlighting))
 449             (vm-highlight-headers))
 450         ;; Display XFaces with VM internal support if appropriate
 451         (if (and vm-display-xfaces
 452                  running-xemacs
 453                  (vm-multiple-frames-possible-p)
 454                  (featurep 'xface))
 455             (let ((highlight-headers-hack-x-face-p t)
 456                   (highlight-headers-regexp nil)
 457                   (highlight-headers-citation-regexp nil)
 458                   (highlight-headers-citation-header-regexp nil))
 459               (highlight-headers (point-min) (point-max) t)))
 460         ;; Energize URLs and buttons
 461         (if (and tm-vm/use-original-url-button
 462                  vm-use-menus (vm-menu-support-possible-p))
 463             (progn (vm-energize-headers)
 464                    (vm-energize-urls)))
 465         (run-hooks 'tm-vm/build-mime-preview-buffer-hook)
 466         ))))
 467
 468 (defun tm-vm/sync-preview-buffer ()
 469   "Ensure that the MIME preview buffer, if it exists, actually corresponds to the current message.
 470 If no MIME Preview buffer is needed then kill it. If no
 471 MIME Preview buffer exists nothing is done."
 472   ;; Current buffer should be message buffer when calling this function
 473   (let* ((mbuf (current-buffer))
 474          (pbuf (and mime::article/preview-buffer
 475                     (get-buffer mime::article/preview-buffer))))
 476     (if pbuf
 477         ;; A MIME Preview buffer exists then it may need to be synch'ed
 478         (save-excursion
 479           (set-buffer mbuf)
 480           (if (and tm-vm/strict-mime
 481                    (not (vm-get-header-contents (car vm-message-pointer)
 482                                                 "MIME-Version:")))
 483               (progn
 484                 (setq mime::article/preview-buffer nil
 485                       tm-vm/system-state nil)
 486                 (if pbuf (kill-buffer pbuf)))
 487             (tm-vm/build-preview-buffer)))
 488           ;; Return to previous frame
 489           )))
 490
 491 (defun tm-vm/toggle-preview-mode ()
 492   "Toggle automatic MIME preview on or off.
 493 In automatic MIME Preview mode each newly selected article is MIME processed if
 494 it has MIME content without need for an explicit request from the user. This
 495 behaviour is controlled by the variable tm-vm/automatic-mime-preview."
 496
 497   (interactive)
 498   (if tm-vm/automatic-mime-preview
 499       (progn
 500         (tm-vm/quit-view-message)
 501         (setq tm-vm/automatic-mime-preview nil)
 502         (message "Automatic MIME Preview is now disabled."))
 503     ;; Enable Automatic MIME Preview
 504     (tm-vm/view-message)
 505     (setq tm-vm/automatic-mime-preview t)
 506     (message "Automatic MIME Preview is now enabled.")
 507     ))
 508
 509 ;;; @@ Display functions
 510
 511 (defun tm-vm/update-message-status ()
 512   "Update current message display and summary.
 513 Remove 'unread' and 'new' flags.  The MIME Preview buffer is not displayed,
 514 tm-vm/display-preview-buffer should be called for that. This function is
 515 display-configuration safe."
 516   (if mime::preview/article-buffer
 517       (set-buffer mime::preview/article-buffer)
 518     (vm-select-folder-buffer))
 519   (if (or (and mime::article/preview-buffer
 520                (get-buffer mime::article/preview-buffer)
 521                (vm-get-visible-buffer-window mime::article/preview-buffer))
 522           (vm-get-visible-buffer-window (current-buffer)))
 523       (progn
 524         (if (vm-new-flag (car vm-message-pointer))
 525             (vm-set-new-flag (car vm-message-pointer) nil))
 526         (if (vm-unread-flag (car vm-message-pointer))
 527             (vm-set-unread-flag (car vm-message-pointer) nil))
 528         (vm-update-summary-and-mode-line)
 529         (tm-vm/howl-if-eom))
 530     (vm-update-summary-and-mode-line)))
 531
 532 (defun tm-vm/display-preview-buffer ()
 533   "Replace the VM message buffer with the MIME-Preview buffer if the VM message buffer is currently displayed or undisplay it if tm-vm/system-state is nil."
 534   (let* ((mbuf (current-buffer))
 535          (mwin (vm-get-visible-buffer-window mbuf))
 536          (pbuf (and mime::article/preview-buffer
 537                     (get-buffer mime::article/preview-buffer)))
 538          (pwin (and pbuf (vm-get-visible-buffer-window pbuf))))
 539     (if (and pbuf (tm-vm/system-state))
 540         ;; display preview buffer if preview-buffer exists
 541         (cond
 542          ((and mwin pwin)
 543           (vm-undisplay-buffer mbuf)
 544           (tm-vm/update-message-status))
 545          ((and mwin (not pwin))
 546           (set-window-buffer mwin pbuf)
 547           (tm-vm/update-message-status))
 548          (pwin
 549           (tm-vm/update-message-status))
 550          (t
 551           ;; don't display if neither mwin nor pwin was displayed before.
 552           ))
 553       ;; display folder buffer
 554       (cond
 555        ((and mwin pwin)
 556         (vm-undisplay-buffer pbuf))
 557        ((and (not mwin) pwin)
 558         (set-window-buffer pwin mbuf))
 559        (mwin
 560         ;; folder buffer is already displayed.
 561         )
 562        (t
 563         ;; don't display if neither mwin nor pwin was displayed before.
 564         )))))
 565
 566 (defun tm-vm/preview-current-message ()
 567   "Either preview message (view first lines only) or MIME-Preview it.
 568 The message is previewed if message previewing is enabled see vm-preview-lines.
 569 If not, MIME-Preview current message (ie. parse MIME
 570 contents and display appropriately) if it has MIME contents and
 571 tm-vm/automatic-mime-preview is non nil. Installed on vm-visit-folder-hook and
 572 vm-select-message-hook."
 573   ;; assumed current buffer is folder buffer.
 574   (setq tm-vm/system-state nil)
 575   (if (get-buffer mime/output-buffer-name)
 576       (vm-undisplay-buffer mime/output-buffer-name))
 577   (if (and vm-message-pointer
 578            tm-vm/automatic-mime-preview
 579            (or (null vm-preview-lines)
 580                (not (eq vm-system-state 'previewing))
 581                (and (not vm-preview-read-messages)
 582                     (not (vm-new-flag (car vm-message-pointer)))
 583                     (not (vm-unread-flag (car vm-message-pointer))))))
 584       (if (or (not tm-vm/strict-mime)
 585               (vm-get-header-contents (car vm-message-pointer)
 586                                       "MIME-Version:"))
 587           ;; do MIME processing.
 588           (progn
 589             (tm-vm/build-preview-buffer)
 590             (save-excursion
 591               (set-buffer mime::article/preview-buffer)
 592               (run-hooks 'tm-vm/select-message-hook)))
 593         ;; don't do MIME processing. decode header only.
 594         (let (buffer-read-only)
 595           (mime/decode-message-header)
 596           (run-hooks 'tm-vm/select-message-hook))
 597         )
 598     ;; don't preview; do nothing.
 599     (run-hooks 'tm-vm/select-message-hook))
 600   (tm-vm/display-preview-buffer))
 601
 602 (defun tm-vm/view-message ()
 603   "Decode and view the current VM message as a MIME encoded message.
 604 A MIME Preview buffer using mime/viewer-mode is created.
 605 See mime/viewer-mode for more information"
 606   (interactive)
 607   (vm-follow-summary-cursor)
 608   (vm-select-folder-buffer)
 609   (vm-check-for-killed-summary)
 610   (vm-error-if-folder-empty)
 611   (vm-display (current-buffer) t '(tm-vm/view-message
 612                                    tm-vm/toggle-preview-mode)
 613               '(tm-vm/view-message reading-message))
 614   (let ((tm-vm/automatic-mime-preview t))
 615     (tm-vm/preview-current-message))
 616 )
 617
 618 (defun tm-vm/quit-view-message ()
 619   "Quit MIME-Viewer and go back to normal VM.
 620 MIME Preview buffer is killed. This function is called by `mime-viewer/quit'
 621 command via `mime-viewer/quitting-method-alist'."
 622   (if (get-buffer mime/output-buffer-name)
 623       (vm-undisplay-buffer mime/output-buffer-name))
 624   (vm-select-folder-buffer)
 625   (let* ((mbuf (current-buffer))
 626          (pbuf (and mime::article/preview-buffer
 627                     (get-buffer mime::article/preview-buffer)))
 628          (pwin (and pbuf (vm-get-visible-buffer-window pbuf))))
 629     (if pbuf (kill-buffer pbuf))
 630     (and pwin
 631          (select-window pwin)
 632          (switch-to-buffer mbuf)))
 633   (setq tm-vm/system-state nil)
 634   (vm-display (current-buffer) t (list this-command)
 635               (list 'reading-message)))
 636
 637 (add-hook 'vm-select-message-hook 'tm-vm/preview-current-message)
 638 (add-hook 'vm-visit-folder-hook   'tm-vm/preview-current-message)
 639
 640
 641
 642 \f
 643
 644 ;;; @@ for tm-view
 645
 646 ;;; based on vm-do-reply [vm-reply.el]
 647 (defun tm-vm/do-reply (buf to-all include-text)
 648   (save-excursion
 649     (set-buffer buf)
 650     (let ((dir default-directory)
 651           to cc subject in-reply-to references newsgroups)
 652       (cond ((setq to
 653                    (let ((reply-to (std11-field-body "Reply-To")))
 654                      (if (vm-ignored-reply-to reply-to)
 655                          nil
 656                        reply-to))))
 657             ((setq to (std11-field-body "From")))
 658             ;; (t (error "No From: or Reply-To: header in message"))
 659             )
 660       (if to-all
 661           (setq cc (delq nil (cons cc (std11-field-bodies '("To" "Cc"))))
 662                 cc (mapconcat 'identity cc ","))
 663         )
 664       (setq subject (std11-field-body "Subject"))
 665       (and subject vm-reply-subject-prefix
 666            (let ((case-fold-search t))
 667              (not
 668               (equal
 669                (string-match (regexp-quote vm-reply-subject-prefix)
 670                              subject)
 671                0)))
 672            (setq subject (concat vm-reply-subject-prefix subject)))
 673       (setq in-reply-to (std11-field-body "Message-Id")
 674             references (nconc
 675                         (std11-field-bodies '("References" "In-Reply-To"))
 676                         (list in-reply-to))
 677             newsgroups (list (or (and to-all
 678                                       (std11-field-body "Followup-To"))
 679                                  (std11-field-body "Newsgroups"))))
 680       (setq to (vm-parse-addresses to)
 681             cc (vm-parse-addresses cc))
 682       (if vm-reply-ignored-addresses
 683           (setq to (vm-strip-ignored-addresses to)
 684                 cc (vm-strip-ignored-addresses cc)))
 685       (setq to (vm-delete-duplicates to nil t))
 686       (setq cc (vm-delete-duplicates
 687                 (append (vm-delete-duplicates cc nil t)
 688                         to (copy-sequence to))
 689                 t t))
 690       (and to (setq to (mapconcat 'identity to ",\n ")))
 691       (and cc (setq cc (mapconcat 'identity cc ",\n ")))
 692       (and (null to) (setq to cc cc nil))
 693       (setq references (delq nil references)
 694             references (mapconcat 'identity references " ")
 695             references (vm-parse references "[^<]*\\(<[^>]+>\\)")
 696             references (vm-delete-duplicates references)
 697             references (if references (mapconcat 'identity references "\n\t")))
 698       (setq newsgroups (delq nil newsgroups)
 699             newsgroups (mapconcat 'identity newsgroups ",")
 700             newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
 701             newsgroups (vm-delete-duplicates newsgroups)
 702             newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
 703       (vm-mail-internal
 704        (if to
 705            (format "reply to %s%s"
 706                    (std11-full-name-string
 707                     (car (std11-parse-address-string to)))
 708                    (if cc ", ..." "")))
 709        to subject in-reply-to cc references newsgroups)
 710       (setq mail-reply-buffer buf
 711             ;; vm-system-state 'replying
 712             default-directory dir))
 713     (if include-text
 714         (save-excursion
 715           (goto-char (point-min))
 716           (let ((case-fold-search nil))
 717             (re-search-forward
 718              (concat "^" (regexp-quote mail-header-separator) "$") nil 0))
 719           (forward-char 1)
 720           (tm-vm/yank-content)))
 721     (run-hooks 'vm-reply-hook)
 722     (run-hooks 'vm-mail-mode-hook)
 723     ))
 724
 725 (defun tm-vm/following-method (buf)
 726   (tm-vm/do-reply buf 'to-all 'include-text)
 727   )
 728
 729 (defun tm-vm/yank-content ()
 730   (interactive)
 731   (let ((this-command 'vm-yank-message))
 732     (vm-display nil nil '(vm-yank-message)
 733                 '(vm-yank-message composing-message))
 734     (save-restriction
 735       (narrow-to-region (point)(point))
 736       (insert-buffer mail-reply-buffer)
 737       (goto-char (point-max))
 738       (push-mark)
 739       (goto-char (point-min)))
 740     (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
 741           (mail-yank-hooks (run-hooks 'mail-yank-hooks))
 742           (t (mail-indent-citation)))
 743     ))
 744
 745 (set-alist 'mime-viewer/following-method-alist
 746            'vm-mode
 747            (function tm-vm/following-method))
 748 (set-alist 'mime-viewer/following-method-alist
 749            'vm-virtual-mode
 750            (function tm-vm/following-method))
 751
 752 (set-alist 'mime-viewer/quitting-method-alist
 753            'vm-mode
 754            'tm-vm/quit-view-message)
 755 (set-alist 'mime-viewer/quitting-method-alist
 756            'vm-virtual-mode
 757            'tm-vm/quit-view-message)
 758
 759 ;;; @@ Motion commands
 760
 761 (defmacro tm-vm/save-window-excursion (&rest forms)
 762   (list 'let '((tm-vm/selected-window (selected-window)))
 763         (list 'unwind-protect
 764               (cons 'progn forms)
 765               '(if (window-live-p tm-vm/selected-window)
 766                    (select-window tm-vm/selected-window)))))
 767
 768 (defmacro tm-vm/save-frame-excursion (&rest forms)
 769   (list 'let '((tm-vm/selected-frame (vm-selected-frame)))
 770         (list 'unwind-protect
 771               (cons 'progn forms)
 772               '(if (frame-live-p tm-vm/selected-frame)
 773                    (vm-select-frame tm-vm/selected-frame)))))
 774
 775 (defadvice vm-scroll-forward (around tm-aware activate)
 776   "Made TM-aware (handles the MIME-Preview buffer)."
 777   (if (and
 778        (not (save-excursion
 779               (if mime::preview/article-buffer
 780                   (set-buffer mime::preview/article-buffer))
 781               (vm-select-folder-buffer)
 782               (eq vm-system-state 'previewing)))
 783        (not (tm-vm/system-state)))
 784       (progn
 785         ad-do-it
 786         (tm-vm/display-preview-buffer))
 787     (let* ((mp-changed (vm-follow-summary-cursor))
 788            (mbuf (or (vm-select-folder-buffer) (current-buffer)))
 789            (mwin (vm-get-buffer-window mbuf))
 790            (pbuf (and mime::article/preview-buffer
 791                       (get-buffer mime::article/preview-buffer)))
 792            (pwin (and pbuf (vm-get-buffer-window pbuf)))
 793            )
 794       (vm-check-for-killed-summary)
 795       (vm-error-if-folder-empty)
 796       (cond
 797         ; A new message was selected
 798         ; => leave it to tm-vm/preview-current-message
 799        (mp-changed
 800         nil)
 801        ((eq vm-system-state 'previewing)
 802         (vm-display (current-buffer) t (list this-command) '(reading-message))
 803         (vm-show-current-message)
 804         (tm-vm/preview-current-message))
 805         ; Preview buffer was killed
 806        ((null pbuf)
 807         (tm-vm/preview-current-message))
 808         ; Preview buffer was undisplayed
 809        ((null pwin)
 810         (if (null mwin)
 811             (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
 812                         (list this-command 'reading-message)))
 813         (tm-vm/display-preview-buffer))
 814         ; Preview buffer is displayed => scroll
 815        (t
 816         (tm-vm/save-window-excursion
 817          (select-window pwin)
 818          (set-buffer pbuf)
 819          (if (pos-visible-in-window-p (point-max) pwin)
 820              (if vm-auto-next-message
 821                  (vm-next-message))
 822            ;; not at the end of message. scroll preview buffer only.
 823            (scroll-up)
 824            (tm-vm/howl-if-eom))
 825          ))))
 826     )
 827 )
 828
 829 (defadvice vm-scroll-backward (around tm-aware activate)
 830   "Made TM-aware (handles the MIME-Preview buffer)."
 831   (if (and
 832        (not (save-excursion
 833               (if mime::preview/article-buffer
 834                   (set-buffer mime::preview/article-buffer))
 835               (vm-select-folder-buffer)
 836               (eq vm-system-state 'previewing)))
 837        (not (tm-vm/system-state)))
 838       ad-do-it
 839     (let* ((mp-changed (vm-follow-summary-cursor))
 840            (mbuf (or (vm-select-folder-buffer) (current-buffer)))
 841            (mwin (vm-get-buffer-window mbuf))
 842            (pbuf (and mime::article/preview-buffer
 843                       (get-buffer mime::article/preview-buffer)))
 844            (pwin (and pbuf (vm-get-buffer-window pbuf)))
 845            )
 846       (vm-check-for-killed-summary)
 847       (vm-error-if-folder-empty)
 848       (cond
 849         ; A new message was selected
 850         ; => leave it to tm-vm/preview-current-message
 851        (mp-changed
 852         nil)
 853        ((eq vm-system-state 'previewing)
 854         (tm-vm/update-message-status)
 855         (setq vm-system-state 'reading)
 856         (tm-vm/preview-current-message))
 857         ; Preview buffer was killed
 858        ((null pbuf)
 859         (tm-vm/preview-current-message))
 860         ; Preview buffer was undisplayed
 861        ((null pwin)
 862         (if (null mwin)
 863             (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward)
 864                         (list this-command 'reading-message)))
 865         (tm-vm/display-preview-buffer))
 866         ; Preview buffer is displayed => scroll
 867        (t
 868         (tm-vm/save-window-excursion
 869          (select-window pwin)
 870          (if (pos-visible-in-window-p (point-min) pwin)
 871              nil
 872            ;; not at the end of message. scroll preview buffer only.
 873            (scroll-down))
 874          ))))
 875     ))
 876
 877 (defadvice vm-beginning-of-message (around tm-aware activate)
 878   "Made TM-aware, works properly in MIME-Preview buffers."
 879   (if (not (tm-vm/system-state))
 880       ad-do-it
 881     (vm-follow-summary-cursor)
 882     (vm-select-folder-buffer)
 883     (vm-check-for-killed-summary)
 884     (vm-error-if-folder-empty)
 885     (let ((pbuf (and mime::article/preview-buffer
 886                      (get-buffer mime::article/preview-buffer))))
 887       (if (null pbuf)
 888           (progn
 889             (tm-vm/preview-current-message)
 890             (setq pbuf (get-buffer mime::article/preview-buffer))
 891             ))
 892       (vm-display (current-buffer) t '(vm-beginning-of-message)
 893                   '(vm-beginning-of-message reading-message))
 894       (tm-vm/display-preview-buffer)
 895       (tm-vm/save-window-excursion
 896        (select-window (vm-get-visible-buffer-window pbuf))
 897        (push-mark)
 898        (goto-char (point-min))
 899        (vm-display (current-buffer) t '(vm-beginning-of-message)
 900                    '(vm-beginning-of-message reading-message))
 901        ))))
 902
 903 (defadvice vm-end-of-message (around tm-aware activate)
 904   "Made TM-aware, works properly in MIME-Preview buffers."
 905   (interactive)
 906   (if (not (tm-vm/system-state))
 907       ad-do-it
 908     (vm-follow-summary-cursor)
 909     (vm-select-folder-buffer)
 910     (vm-check-for-killed-summary)
 911     (vm-error-if-folder-empty)
 912     (let ((pbuf (and mime::article/preview-buffer
 913                      (get-buffer mime::article/preview-buffer))))
 914       (if (null pbuf)
 915           (progn
 916             (tm-vm/preview-current-message)
 917             (setq pbuf (get-buffer mime::article/preview-buffer))
 918             ))
 919       (vm-display (current-buffer) t '(vm-end-of-message)
 920                   '(vm-end-of-message reading-message))
 921       (tm-vm/display-preview-buffer)
 922       (tm-vm/save-window-excursion
 923        (select-window (vm-get-buffer-window pbuf))
 924        (push-mark)
 925        (goto-char (point-max))
 926        (vm-display (current-buffer) t '(vm-end-of-message)
 927                    '(vm-end-of-message reading-message))
 928        ))))
 929
 930 ;;; based on vm-howl-if-eom [vm-page.el]
 931 (defun tm-vm/howl-if-eom ()
 932   (let* ((pbuf (or mime::article/preview-buffer (current-buffer)))
 933          (pwin (and (vm-get-visible-buffer-window pbuf))))
 934     (and pwin
 935          (save-excursion
 936            (save-window-excursion
 937              (condition-case ()
 938                  (let ((next-screen-context-lines 0))
 939                    (tm-vm/save-frame-excursion
 940                     (vm-select-frame (vm-window-frame pwin))
 941                     (save-selected-window
 942                       (select-window pwin)
 943                       (save-excursion
 944                         (let ((scroll-in-place-replace-original nil))
 945                           (scroll-up)))))
 946                     nil)
 947                (error t))))
 948          (vm-emit-eom-blurb)
 949          )))
 950
 951 (defadvice vm-emit-eom-blurb (around tm-aware activate)
 952   "Made TM-aware, works properly in MIME-Preview buffers."
 953   (save-excursion
 954     (if mime::preview/article-buffer
 955         (set-buffer mime::preview/article-buffer))
 956     ad-do-it))
 957
 958 (defadvice vm-next-message (around tm-aware activate)
 959   "Made TM-aware, works properly in MIME-Preview buffers."
 960   (if mime::preview/article-buffer
 961       (set-buffer mime::preview/article-buffer))
 962   (tm-vm/save-window-excursion
 963    ad-do-it))
 964
 965 (defadvice vm-previous-message (around tm-aware activate)
 966   "Made TM-aware, works properly in MIME-Preview buffers."
 967   (if mime::preview/article-buffer
 968       (set-buffer mime::preview/article-buffer))
 969   (tm-vm/save-window-excursion
 970    ad-do-it))
 971
 972 (defadvice vm-next-message-no-skip (around tm-aware activate)
 973   "Made TM-aware, works properly in MIME-Preview buffers."
 974   (if mime::preview/article-buffer
 975       (set-buffer mime::preview/article-buffer))
 976   (tm-vm/save-window-excursion
 977    ad-do-it))
 978
 979 (defadvice vm-previous-message-no-skip (around tm-aware activate)
 980   "TM wrapper for vm-previous-message-no-skip (which see)."
 981   (if mime::preview/article-buffer
 982       (set-buffer mime::preview/article-buffer))
 983   (tm-vm/save-window-excursion
 984      ad-do-it))
 985
 986 (defadvice vm-next-unread-message (around tm-aware activate)
 987   "Made TM-aware, works properly in MIME-Preview buffers."
 988   (if mime::preview/article-buffer
 989       (set-buffer mime::preview/article-buffer))
 990   (tm-vm/save-window-excursion
 991    ad-do-it))
 992
 993 (defadvice vm-previous-unread-message (around tm-aware activate)
 994   "Made TM-aware, works properly in MIME-Preview buffers."
 995   (if mime::preview/article-buffer
 996       (set-buffer mime::preview/article-buffer))
 997   (tm-vm/save-window-excursion
 998    ad-do-it))
 999
1000
1001 (set-alist 'mime-viewer/over-to-previous-method-alist
1002            'vm-mode 'vm-previous-message)
1003 (set-alist 'mime-viewer/over-to-next-method-alist
1004            'vm-mode 'vm-next-message)
1005 (set-alist 'mime-viewer/over-to-previous-method-alist
1006            'vm-virtual-mode 'vm-previous-message)
1007 (set-alist 'mime-viewer/over-to-next-method-alist
1008            'vm-virtual-mode 'vm-next-message)
1009
1010
1011
1012
1013 \f
1014
1015 ;;; @ MIME Editor
1016
1017 ;;; @@ vm-yank-message
1018
1019
1020 (defvar tm-vm/yank:message-to-restore nil
1021   "For internal use by tm-vm only.")
1022
1023 (defun vm-yank-message (&optional message)
1024   "Yank message number N into the current buffer at point.
1025 When called interactively N is always read from the minibuffer.  When
1026 called non-interactively the first argument is expected to be a
1027 message struct.
1028
1029 This function originally provided by vm-reply has been patched for TM
1030 in order to provide better citation of MIME messages : if a MIME
1031 Preview buffer exists for the message then its contents are inserted
1032 instead of the raw message.
1033
1034 This command is meant to be used in VM created Mail mode buffers; the
1035 yanked message comes from the mail buffer containing the message you
1036 are replying to, forwarding, or invoked VM's mail command from.
1037
1038 All message headers are yanked along with the text.  Point is
1039 left before the inserted text, the mark after.  Any hook
1040 functions bound to mail-citation-hook are run, after inserting
1041 the text and setting point and mark.  For backward compatibility,
1042 if mail-citation-hook is set to nil, `mail-yank-hooks' is run
1043 instead.
1044
1045 If mail-citation-hook and mail-yank-hooks are both nil, this
1046 default action is taken: the yanked headers are trimmed as
1047 specified by vm-included-text-headers and
1048 vm-included-text-discard-header-regexp, and the value of
1049 vm-included-text-prefix is prepended to every yanked line."
1050   (interactive
1051    (list
1052     ;; What we really want for the first argument is a message struct,
1053     ;; but if called interactively, we let the user type in a message
1054     ;; number instead.
1055     (let (mp default
1056              (result 0)
1057              prompt
1058              (last-command last-command)
1059              (this-command this-command))
1060       (if (bufferp vm-mail-buffer)
1061           (save-excursion
1062             (vm-select-folder-buffer)
1063             (setq default (and vm-message-pointer
1064                                (vm-number-of (car vm-message-pointer)))
1065                   prompt (if default
1066                              (format "Yank message number: (default %s) "
1067                                      default)
1068                            "Yank message number: "))
1069             (while (zerop result)
1070               (setq result (read-string prompt))
1071               (and (string= result "") default (setq result default))
1072               (setq result (string-to-int result)))
1073             (if (null (setq mp (nthcdr (1- result) vm-message-list)))
1074                 (error "No such message."))
1075             (setq tm-vm/yank:message-to-restore (string-to-int default))
1076             (save-selected-window
1077               (vm-goto-message result))
1078             (car mp))
1079         nil))))
1080   (if (null message)
1081       (if mail-reply-buffer
1082           (tm-vm/yank-content)
1083         (error "This is not a VM Mail mode buffer."))
1084     (if (null (buffer-name vm-mail-buffer))
1085         (error "The folder buffer containing message %d has been killed."
1086                (vm-number-of message)))
1087     (vm-display nil nil '(vm-yank-message)
1088                 '(vm-yank-message composing-message))
1089     (let ((b (current-buffer)) (start (point)) end)
1090       (save-restriction
1091         (widen)
1092         (save-excursion
1093           (set-buffer (vm-buffer-of message))
1094           (let (pbuf)
1095             (tm-vm/sync-preview-buffer)
1096             (setq pbuf (and mime::article/preview-buffer
1097                             (get-buffer mime::article/preview-buffer)))
1098             (if (and pbuf
1099                      (not (eq this-command 'vm-forward-message)))
1100                 ;; Yank contents of MIME Preview buffer
1101                 (if running-xemacs
1102                     (let ((tmp (generate-new-buffer "tm-vm/tmp")))
1103                       (set-buffer pbuf)
1104                       (append-to-buffer tmp (point-min) (point-max))
1105                       (set-buffer tmp)
1106                       (map-extents
1107                        '(lambda (ext maparg)
1108                           (set-extent-property ext 'begin-glyph nil)))
1109                       (append-to-buffer b (point-min) (point-max))
1110                       (setq end (vm-marker
1111                                  (+ start (length (buffer-string))) b))
1112                       (kill-buffer tmp))
1113                   (set-buffer pbuf)
1114                   (append-to-buffer b (point-min) (point-max))
1115                   (setq end (vm-marker
1116                              (+ start (length (buffer-string))) b)))
1117               ;; Yank contents of raw VM message
1118               (save-restriction
1119                 (setq message (vm-real-message-of message))
1120                 (set-buffer (vm-buffer-of message))
1121                 (widen)
1122                 (append-to-buffer
1123                  b (vm-headers-of message) (vm-text-end-of message))
1124                 (setq end
1125                       (vm-marker (+ start (- (vm-text-end-of message)
1126                                              (vm-headers-of message))) b))))))
1127         (push-mark end)
1128         (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
1129               (mail-yank-hooks (run-hooks 'mail-yank-hooks))
1130               (t (vm-mail-yank-default message)))
1131         ))
1132     (if tm-vm/yank:message-to-restore
1133         (save-selected-window
1134           (vm-goto-message tm-vm/yank:message-to-restore)
1135           (setq tm-vm/yank:message-to-restore nil)))
1136     ))
1137
1138 ;;; @@ for tm-partial
1139 ;;;
1140
1141 (call-after-loaded
1142  'tm-partial
1143  (function
1144   (lambda ()
1145     (set-atype 'mime/content-decoding-condition
1146                '((type . "message/partial")
1147                  (method . mime-article/grab-message/partials)
1148                  (major-mode . vm-mode)
1149                  (summary-buffer-exp . vm-summary-buffer)
1150                  ))
1151     (set-alist 'tm-partial/preview-article-method-alist
1152                'vm-mode
1153                (function
1154                 (lambda ()
1155                   (tm-vm/view-message)
1156                   )))
1157     )))
1158
1159
1160 ;;; @@ for tm-edit
1161 ;;;
1162
1163 (call-after-loaded
1164  'mime-setup
1165  (function
1166   (lambda ()
1167     (setq vm-forwarding-digest-type "rfc1521")
1168     (setq vm-digest-send-type "rfc1521")
1169     )))
1170
1171 ;;; @@@ multipart/digest
1172
1173 (if (not (fboundp 'vm-unsaved-message))
1174     (fset 'vm-unsaved-message 'message))
1175
1176 (defun tm-vm/enclose-messages (mlist &optional preamble)
1177   "Enclose the messages in MLIST as multipart/digest.
1178 The resulting digest is inserted at point in the current buffer.
1179
1180 MLIST should be a list of message structs (real or virtual).
1181 These are the messages that will be enclosed."
1182   (if mlist
1183       (let ((digest (consp (cdr mlist)))
1184             (mp mlist)
1185             m)
1186         (save-restriction
1187           (narrow-to-region (point) (point))
1188           (while mlist
1189             (setq m (vm-real-message-of (car mlist)))
1190             (mime-editor/insert-tag "message" "rfc822")
1191             (tm-mail/insert-message m)
1192             (goto-char (point-max))
1193             (setq mlist (cdr mlist)))
1194           (if preamble
1195               (progn
1196                 (goto-char (point-min))
1197                 (mime-editor/insert-tag "text" "plain")
1198                 (vm-unsaved-message "Building digest preamble...")
1199                 (while mp
1200                   (let ((vm-summary-uninteresting-senders nil))
1201                     (insert
1202                      (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n"))
1203                   (if vm-digest-center-preamble
1204                       (progn
1205                         (forward-char -1)
1206                         (center-line)
1207                         (forward-char 1)))
1208                   (setq mp (cdr mp)))))
1209           (if digest
1210               (mime-editor/enclose-digest-region (point-min) (point-max)))
1211           ))))
1212
1213 (defadvice vm-forward-message (around tm-aware activate)
1214   "Extended to support rfc1521 digests (roughly equivalent to what
1215 VM does when vm-forwarding-digest-type is 'mime but using message/rfc822
1216 when appropriate."
1217   (if (not (equal vm-forwarding-digest-type "rfc1521"))
1218       ad-do-it
1219     (if mime::preview/article-buffer
1220         (set-buffer mime::preview/article-buffer))
1221     (vm-follow-summary-cursor)
1222     (vm-select-folder-buffer)
1223     (vm-check-for-killed-summary)
1224     (vm-error-if-folder-empty)
1225     (if (eq last-command 'vm-next-command-uses-marks)
1226         (let ((vm-digest-send-type vm-forwarding-digest-type))
1227           (setq this-command 'vm-next-command-uses-marks)
1228           (command-execute 'tm-vm/send-digest))
1229       (let ((dir default-directory)
1230             (mp vm-message-pointer))
1231         (save-restriction
1232           (widen)
1233           (vm-mail-internal
1234            (format "forward of %s's note re: %s"
1235                    (vm-su-full-name (car vm-message-pointer))
1236                    (vm-su-subject (car vm-message-pointer)))
1237            nil
1238            (and vm-forwarding-subject-format
1239                 (let ((vm-summary-uninteresting-senders nil))
1240                   (vm-sprintf 'vm-forwarding-subject-format (car mp)))))
1241           (make-local-variable 'vm-forward-list)
1242           (setq vm-system-state 'forwarding
1243                 vm-forward-list (list (car mp))
1244                 default-directory dir)
1245           (goto-char (point-min))
1246           (re-search-forward
1247            (concat "^" (regexp-quote mail-header-separator) "\n") nil 0)
1248           (tm-vm/enclose-messages vm-forward-list)
1249           (mail-position-on-field "To"))
1250         (run-hooks 'tm-vm/forward-message-hook)
1251         (run-hooks 'vm-mail-mode-hook)))))
1252
1253 (defun tm-vm/send-digest (&optional arg)
1254   "Send a digest of all messages in the current folder to recipients.
1255 The type of the digest is specified by the variable vm-digest-send-type.
1256 You will be placed in a Mail mode buffer as is usual with replies, but you
1257 must fill in the To: and Subject: headers manually.
1258
1259 If invoked on marked messages (via vm-next-command-uses-marks),
1260 only marked messages will be put into the digest."
1261   (interactive "P")
1262   (if (not (equal vm-digest-send-type "rfc1521"))
1263       (vm-send-digest arg)
1264     (vm-select-folder-buffer)
1265     (vm-check-for-killed-summary)
1266     (vm-error-if-folder-empty)
1267     (let ((dir default-directory)
1268           (vm-forward-list (if (eq last-command 'vm-next-command-uses-marks)
1269                                (vm-select-marked-or-prefixed-messages 0)
1270                              vm-message-list)))
1271       (save-restriction
1272         (widen)
1273         (vm-mail-internal (format "digest from %s" (buffer-name)))
1274         (setq vm-system-state 'forwarding
1275               default-directory dir)
1276         (goto-char (point-min))
1277         (re-search-forward (concat "^" (regexp-quote mail-header-separator)
1278                                    "\n"))
1279         (goto-char (match-end 0))
1280         (vm-unsaved-message "Building %s digest..." vm-digest-send-type)
1281         (tm-vm/enclose-messages vm-forward-list arg)
1282         (mail-position-on-field "To")
1283         (message "Building %s digest... done" vm-digest-send-type)))
1284     (run-hooks 'tm-vm/send-digest-hook)
1285     (run-hooks 'vm-mail-mode-hook)))
1286
1287 (substitute-key-definition 'vm-send-digest
1288                            'tm-vm/send-digest vm-mode-map)
1289
1290 ;;; @@@ Menus
1291
1292
1293 (call-after-loaded
1294  'tm-edit
1295  (function
1296   (lambda ()
1297     (autoload 'tm-mail/insert-message "tm-mail")
1298     (set-alist 'mime-editor/message-inserter-alist
1299                'mail-mode (function tm-mail/insert-message))
1300     (set-alist 'mime-editor/split-message-sender-alist
1301                'mail-mode (function
1302                            (lambda ()
1303                              (interactive)
1304                              (funcall send-mail-function)
1305                              )))
1306     )))
1307
1308 \f
1309
1310 ;;; @ VM Integration
1311
1312 (add-hook 'vm-quit-hook 'tm-vm/quit-view-message)
1313
1314 ;;; @@ Wrappers for miscellaneous VM functions
1315
1316 (defadvice vm-summarize (around tm-aware activate)
1317   "Made TM aware. Callable from the MIME Preview buffer."
1318   (if mime::preview/article-buffer
1319       (set-buffer mime::preview/article-buffer))
1320   ad-do-it
1321   (save-excursion
1322     (set-buffer vm-summary-buffer)
1323     (tm-vm/check-for-toolbar))
1324   (tm-vm/preview-current-message))
1325
1326 (defadvice vm-expose-hidden-headers (around tm-aware activate)
1327   "Made TM aware. Callable from the MIME Preview buffer."
1328   (if mime::preview/article-buffer
1329       (set-buffer mime::preview/article-buffer))
1330   (let ((visible-headers vm-visible-headers))
1331     (tm-vm/quit-view-message)
1332     ad-do-it
1333     (let ((vm-visible-headers visible-headers))
1334       (if (= (point-min) (vm-start-of (car vm-message-pointer)))
1335           (setq vm-visible-headers '(".*")))
1336       (tm-vm/preview-current-message))))
1337
1338 (if (vm-mouse-fsfemacs-mouse-p)
1339     (progn
1340       (define-key tm-vm/vm-emulation-map [mouse-3] 'ignore)
1341       (define-key tm-vm/vm-emulation-map [down-mouse-3] 'vm-mouse-button-3)
1342       (defadvice vm-mouse-button-3 (after tm-aware activate)
1343         "Made TM aware. Works in MIME-Preview buffers."
1344         (if (and
1345              vm-use-menus
1346              (eq major-mode 'mime/viewer-mode))
1347             (vm-menu-popup-mode-menu event))))
1348 )
1349
1350 (defadvice vm-save-message (around tm-aware activate)
1351   "Made TM aware. Callable from the MIME Preview buffer."
1352   (if mime::preview/article-buffer
1353       (save-excursion
1354         (set-buffer mime::preview/article-buffer)
1355         ad-do-it)
1356     ad-do-it))
1357
1358 (defadvice vm-expunge-folder (around tm-aware activate)
1359   "Made TM aware. Callable from the MIME Preview buffer."
1360   (if mime::preview/article-buffer
1361       (save-excursion
1362         (set-buffer mime::preview/article-buffer)
1363         ad-do-it)
1364     ad-do-it))
1365
1366 (defadvice vm-save-folder (around tm-aware activate)
1367   "Made TM aware. Callable from the MIME Preview buffer."
1368   (if mime::preview/article-buffer
1369       (save-excursion
1370         (set-buffer mime::preview/article-buffer)
1371         ad-do-it)
1372     ad-do-it))
1373
1374 (defadvice vm-goto-parent-message (around tm-aware activate)
1375   "Made TM aware. Callable from the MIME Preview buffer."
1376   (if mime::preview/article-buffer
1377       (save-excursion
1378         (set-buffer mime::preview/article-buffer)
1379         ad-do-it)
1380     ad-do-it))
1381
1382 (defadvice vm-delete-message (around tm-aware activate)
1383   "Made TM aware. Callable from the MIME Preview buffer."
1384   (interactive "p")
1385   (if (interactive-p)
1386       (vm-follow-summary-cursor))
1387   (if mime::preview/article-buffer
1388       (save-excursion
1389         (set-buffer mime::preview/article-buffer)
1390         ad-do-it)
1391     ad-do-it))
1392
1393 (defadvice vm-delete-message-backward (around tm-aware activate)
1394   "Made TM aware. Callable from the MIME Preview buffer."
1395   (interactive "p")
1396   (if (interactive-p)
1397       (vm-follow-summary-cursor))
1398   (if mime::preview/article-buffer
1399       (save-excursion
1400         (set-buffer mime::preview/article-buffer)
1401         ad-do-it)
1402     ad-do-it))
1403
1404 (defadvice vm-undelete-message (around tm-aware activate)
1405   "Made TM aware. Callable from the MIME Preview buffer."
1406   (interactive "p")
1407   (if (interactive-p)
1408       (vm-follow-summary-cursor))
1409   (if mime::preview/article-buffer
1410       (save-excursion
1411         (set-buffer mime::preview/article-buffer)
1412         ad-do-it)
1413     ad-do-it))
1414
1415 (defadvice vm-unread-message (around tm-aware activate)
1416   "Made TM aware. Callable from the MIME Preview buffer."
1417   (if mime::preview/article-buffer
1418       (save-excursion
1419         (set-buffer mime::preview/article-buffer)
1420         ad-do-it)
1421     ad-do-it))
1422
1423 (defadvice vm-edit-message (around tm-aware activate)
1424   "Made TM aware. Callable from the MIME Preview buffer."
1425   (if mime::preview/article-buffer
1426       (save-excursion
1427         (set-buffer mime::preview/article-buffer)
1428         ad-do-it)
1429     ad-do-it))
1430
1431
1432
1433 ;;; @@ VM Toolbar Integration
1434
1435 ;;; based on vm-toolbar-any-messages-p [vm-toolbar.el]
1436 (defun tm-vm/check-for-toolbar ()
1437   "Install VM toolbar if necessary."
1438   (if (and running-xemacs
1439            vm-toolbar-specifier)
1440       (progn
1441         (if (null (specifier-instance vm-toolbar-specifier))
1442             (vm-toolbar-install-toolbar))
1443         (vm-toolbar-update-toolbar))))
1444
1445 (defun vm-toolbar-any-messages-p ()
1446   (save-excursion
1447     (if mime::preview/article-buffer
1448         (set-buffer mime::preview/article-buffer))
1449     (vm-check-for-killed-folder)
1450     (vm-select-folder-buffer)
1451     vm-message-list))
1452
1453
1454 ;;; @ BBDB Integration
1455 ;;;
1456
1457 (call-after-loaded
1458  'bbdb
1459  (function
1460   (lambda ()
1461     (require 'bbdb-vm)
1462     (require 'tm-bbdb)
1463     (defun tm-bbdb/vm-update-record (&optional offer-to-create)
1464       (save-excursion
1465         (vm-select-folder-buffer)
1466         (if (and (tm-vm/system-state)
1467                  mime::article/preview-buffer
1468                  (get-buffer mime::article/preview-buffer))
1469             (let ((tm-bbdb/auto-create-p bbdb/mail-auto-create-p))
1470               (tm-bbdb/update-record offer-to-create))
1471           (or (bbdb/vm-update-record offer-to-create)
1472               (delete-windows-on (get-buffer "*BBDB*")))
1473           )))
1474     (remove-hook 'vm-select-message-hook 'bbdb/vm-update-record)
1475     (remove-hook 'vm-show-message-hook 'bbdb/vm-update-record)
1476     (add-hook 'tm-vm/select-message-hook 'tm-bbdb/vm-update-record)
1477     )))
1478
1479 ;;; @ ps-print (Suggested by Anders Stenman <stenman@isy.liu.se>)
1480 ;;;
1481
1482 (if tm-vm/use-ps-print
1483     (progn
1484       (autoload 'ps-print-buffer-with-faces "ps-print" "Postscript Print" t)
1485       (add-hook 'vm-mode-hook 'tm-vm/ps-print-setup)
1486       (add-hook 'mime-viewer/define-keymap-hook 'tm-vm/ps-print-setup)
1487       (fset 'vm-toolbar-print-command 'tm-vm/print-message)))
1488
1489 (defun tm-vm/ps-print-setup ()
1490   "Set things up for printing MIME messages with ps-print. Set binding to
1491 the [Print Screen] key."
1492   (local-set-key (if running-xemacs
1493                      'f22
1494                    [f22])
1495                  'tm-vm/print-message)
1496   (make-local-variable 'ps-header-lines)
1497   (make-local-variable 'ps-left-header)
1498   (setq ps-header-lines 3)
1499   (setq ps-left-header
1500         (list 'ps-article-subject 'ps-article-author 'buffer-name)))
1501
1502 (defun tm-vm/print-message ()
1503   "Print current message with ps-print if it's a MIME message.
1504 Value of tm-vm/strict-mime is also taken into consideration."
1505   (interactive)
1506   (vm-follow-summary-cursor)
1507   (vm-select-folder-buffer)
1508   (tm-vm/sync-preview-buffer)
1509   (let ((pbuf (and mime::article/preview-buffer
1510                   (get-buffer mime::article/preview-buffer))))
1511     (if pbuf
1512         (save-excursion
1513           (set-buffer pbuf)
1514           (require 'ps-print)
1515           (ps-print-buffer-with-faces))
1516       (vm-print-message))))
1517
1518
1519 ;;; @ end
1520
1521 (provide 'tm-vm)
1522 (run-hooks 'tm-vm-load-hook)
1523
1524 ;;; tm-vm.el ends here.