Mercurial > hg > xemacs-beta

comparison lisp/tm/tm-vm.el @ 16:0293115a14e9 r19-15b91

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